-
Notifications
You must be signed in to change notification settings - Fork 0
/
parser.pl
executable file
·251 lines (220 loc) · 9.98 KB
/
parser.pl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
#!/usr/bin/perl -w
# parser.pl - main code of email2aprs to parse emails and make APRS!
######################################################################
# (C) Copyright 2020-2021 "Nosey" Nick Waterman VA3NNW
# <e2a-copyright@noseynick.com> https://github.com/NoseyNick/email2aprs
######################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
######################################################################
use strict; # OR ELSE!
use MIME::Parser; # for parsing MIME emails of course!
use Encode qw(decode);
use Date::Parse qw(str2time);
use POSIX qw(strftime);
use IO::Socket::INET; # For APRS upload
our $VERSION = '1.01';
our $MAJOR = substr($VERSION,0,1);
# defaults for stuff we intend to parse out of AUTH, email, or TOKENs therein:
my %dat = (
AUTH => $ENV{AUTH} // 'AUTH', # to point to different AUTH file
TOKEN => $ENV{TOKEN}, # can use env var to "sideload" a default token
# ... AUTH or TOKENs/etoa-BLAH can contain any of these "key: val":
APRSIS => '127.1:14580', # connect to Server:Port
# USER => 'VA3NNW-E', # email2aprs USER for APRS-IS - read from "AUTH"
# PASS => -1, # email2aprs PASS for APRS-IS - read from "AUTH"
TIMEOUT => 10, # number of seconds to wait for APRS-IS response
# CALL => 'VA3NNW-E', # MUST get via TOKEN mechanism
TOCALL => "APE2A$MAJOR", # http://www.aprs.org/aprs11/tocalls.txt
PATH => 'TCPIP*', # See http://www.aprs-is.net/Connecting.aspx
# Lowercase ones can also be overridden in the email. If TOKENs/etoa-BLAH has:
# def-key: val # ... then email body can contain:
# key: val # ... to override
msg => '', # empty msg if not set elsewhere
obj => '', # 3-9-char object name, space-padded later
sym => '', # See http://wa8lmf.net/aprs/APRS_symbols.htm
);
### Create parser, and set some parsing options:
my $parser = new MIME::Parser;
$parser -> output_to_core(1);
$parser -> tmp_to_core(1);
# $parser -> decode_headers(1); # can result in unparseable headers
$parser -> extract_nested_messages(1);
$parser -> ignore_errors(1);
### Parse input:
my $ent = eval { $parser->parse(\*STDIN) }
or fatal('parse failed'); # no sense retrying
# or parse_data(\$scalar);
crawl($ent);
sub crawl {
my ($ent) = @_;
for my $key (qw(From To Date Return-path Envelope-to Subject Message-ID)) {
my $val = $ent->head->get($key);
next unless $val;
$val = decode('MIME-Header', $val);
chomp $val; # lose LF
$dat{$key} = $val;
if ($key eq 'Date') {
my $time = str2time($val) or next;
# $dat{ISODate} = strftime('%Y-%m-%dT%H:%M:%SZ', gmtime($time));
# +++ Perhaps TOKKEN-based feature flag to select:
$dat{APRSTime} = strftime('%d%H%Mz', gmtime($time));
# $dat{APRSTime} = strftime('%H%M%Sh', gmtime($time));
} elsif ($key eq 'Envelope-to' or $key eq 'Subject') {
check_toks($val);
}
}
if ($ent->effective_type =~ '^text/') {
$dat{_bodies}++;
my $body = $ent->bodyhandle || { as_string => '' };
$body = $body->as_string || '';
$body =~ s/<.*?>/\n/g;
# Garmin / inReach / others:
# A bunch of URLs with lat=YYY@lon=XXX:
$dat{Lat} = $1 if $body =~ /\bLat[= ]([-+]?\d+\.\d+)/i;
$dat{Lon} = $1 if $body =~ /\bLon[= ]([-+]?\d+\.\d+)/i;
# anything capable of sharing a geo: url:
@dat{'Lat','Lon'} = ($1, $2) if $body =~ /\bgeo:([-+]?\d+\.\d+),([-+]?\d+\.\d+)/;
for (grep {/^[a-z]*$/} keys %dat) {
# the lower-case keys can be overridden in the body:
# probably just msg, obj, sym:
$dat{$_} = $1 if $body =~ /\b$_: *(.*)/i;
}
check_toks($body);
}
for my $part ($ent->parts) {
# To define recursion, we must first define recursion:
crawl($part);
# ... to parse sub-parts, and sub-sub parts
}
}
sub check_toks {
return unless $_[0] =~ s/(etoa-[a-z]+)//i; # MODIFY first arg
$dat{TOKEN} = lc $1;
}
# read an AUTH file or TOKENs/etoa-blah, set all the vars/defaults:
sub readconf {
my ($fi) = @_;
open(IN, $fi) or return;
while (<IN>) {
s/\s*#.*//; # strip trailing comments
if (/^def-(\w+): *(.*)/) { $dat{$1} ||= $2; }
elsif (/^(\w+): *(.*)/) { $dat{$1} = $2; }
}
return close IN;
}
# contains global settings, USER:, PASS:, probably APRSIS:, maybe TIMEOUT:
my $AUTH = delete $dat{AUTH} // 'AUTH';
readconf($AUTH) or err("Unable to read $AUTH: $!");
# contains CALL and any other per-TOKEN options:
readconf("TOKENs/$dat{TOKEN}") if $dat{TOKEN};
# ... don't worry about TOKEN errors though - stale TOKENs handled by:
fatal('No CALL/TOKEN') unless $dat{CALL}; # no sense retrying
# See if we have Lat/Lon/sym to create a valid APRS position
sub { # anonymous sub just so we can "return" to bail early
my $lat = delete $dat{Lat};
my $lon = delete $dat{Lon};
(delete $dat{sym} // '') =~ /^(.)(.)/; # boobies!
my ($symtab, $sym) = ($1 // '/', $2 // '/'); # Red dot - sym of last resort
return unless defined($lat) && $lat =~ /^[-+]?\d+\.\d+$/;
return unless $lat >= -90 && $lat <= 90;
return unless defined($lon) && $lon =~ /^[-+]?\d+\.\d+$/;
return unless $lon >= -180 && $lon <= 180;
my ($ns, $ew) = ('N', 'E');
if ($lat < 0) { $lat = -$lat; $ns = 'S'; }
if ($lon < 0) { $lon = -$lon; $ew = 'W'; }
# +++ Perhaps TOKEN-based position ambiguity setting?
$dat{APRSPos} = sprintf
'%02d' . '%05.2f' . '%1.1s' . '%1.1s' .
'%03d' . '%05.2f' . '%1.1s' . '%1.1s',
$lat, ($lat - int $lat) * 60, $ns, $symtab,
$lon, ($lon - int $lon) * 60, $ew, $sym;
} -> ();
# Try to assemble an APRS packet from various fragments:
sub APRS {
my $type = shift;
my $packet = '';
for ('CALL', '>', 'TOCALL', ',', 'PATH', ':', @_) {
# try to insert various packet fragments, return if we can't:
if (/^[A-Za-z]/) { $packet .= $dat{$_} // return; }
else { $packet .= $_; } # insert symbols and stuff
}
# If we got here, we have sucessfully assembled a whole packet:
$dat{-APRS} = $packet;
delete @dat{qw(CALL TOCALL PATH), @_}; # "consumed" them - shorter logs.
return $dat{APRSType} = $type;
}
# Could check for presence of each of these fields but honestly
# easier to just attempt to build packet and fail a few times:
if ($dat{obj}) {
$dat{obj} = sprintf('%-9.9s', $dat{obj}); # min9 max9 ch, space-pad
# note ITEMS are '%-3.9s' (see below) # min3 max9 ch not padded
} else {
delete $dat{obj};
}
APRS qw(Object ; obj * APRSTime APRSPos msg)
# +++ or _ ... to kill?
# +++ or Item \) item ! with no APRSTime?
# +++ or Item \) item _ to kill?
or APRS qw(TimePos / APRSTime APRSPos msg)
or APRS qw(Pos ! APRSPos msg)
or ($dat{msg} && APRS qw(Status > msg))
# ++++ TOKEN-based flag to say we DO want positionless Status msg?:
# COULD send APRS(qw(Status > APRSTime)) - pointless w/o Pos or msg?
or fatal('No packet to send'); # no sense retrying
# Now see if we can send it:
$SIG{ALRM} = sub { err('Timeout'); };
alarm $dat{TIMEOUT}; # ... if no response
my $peer = delete $dat{APRSIS} or return err('No APRSIS server:port');
my $USER = delete $dat{USER} or return err('No USER');
my $PASS = delete $dat{PASS} or return err('No PASS');
my $aprsis = new IO::Socket::INET ( PeerAddr => $peer )
or err("Connect $peer - $!");
print $aprsis "user $USER pass $PASS vers email2aprs $VERSION\n$dat{-APRS}\n";
my $n = 0;
while (<$aprsis>) {
chomp;
$dat{sprintf('-RESP%02d',$n)} = $_;
last if /logresp/;
err('Too much response') if ++$n > 50;
}
alarm 0;
# sleep 1; # allow 1sec extra for packet to flush?
close $aprsis;
done(OK => 'SENT');
# As per https://www.exim.org/exim-html-3.20/doc/html/spec_18.html#SEC534 ...
sub err { done(ERR => @_, 45); } # EX_TEMPFAIL so exim will retry later
sub fatal { done(FATAL => @_); } # exit 0 misleading but exim WON'T try again
sub done {
my ($status, $msg, $exit) = @_;
$dat{"-$status"} = $msg;
my $LOG = strftime('%Y-%m-%dT%H:%M:%SZ ', gmtime( $^T )) # program start time
. '#'x60 . "\n";
for (sort keys %dat) {
next unless $dat{$_};
$LOG .= "$_: $dat{$_}\n";
}
print $LOG;
exit ($exit // 0);
}
######################################################################
# For posterity, the first ever email2aprs packets gated to APRS-IS:
# 2020-04-23 04:05Z First packet ever sent from email2aprs to APRS-IS, v.manual, TOKEN edited in etc:
# KE5CEP-E>APRS,TCPIP*,qAS,VA3NNW:/231405z3552.96N/10617.29W/Testing email2aprs (simulated position)
# 2020-04-24 03:54Z First packet with real TOKEN ever gated UNEDITED, though still semi-manual:
# KE5CEP-E>APRS,TCPIP*:/240250z3553.01N/10618.53W/Testing email2aprs (simulated position)
# KE5CEP-E>APRS,TCPIP*,qAS,VA3NNW:/240250z3553.01N/10618.53W/Testing email2aprs (simulated position)
# 2020-04-27 03:29Z First packet that really did go email to APRS-IS, no human MitM:
# VA3NNW-4>APRS,TCPIP*,qAS,VA3NNW-E:>NoseyNick testing, please ignore
# 2020-04-27 03:31Z ... followed by a buggy object with 0-length name:
# VA3NNW-4>APRS,TCPIP*,qAS,VA3NNW-E:;*270331z4327.61NN08034.79WnNoseyNick testing, please ignore [Invalid object]
# 2020-04-27 03:39Z ... followed by a "real" (simulated) position:
# VA3NNW-4>APRS,TCPIP*,qAS,VA3NNW-E:/270339z4327.61NN08034.79WnNoseyNick testing, please ignore