our
$VERSION
=
'1.1'
;
my
$COLLECT_URL
=
'//lore.deduce.com/p/collect'
;
my
$VERHASH
=
substr
(sha1_hex(
"perl/$VERSION"
), 0, 16);
my
$TIMEOUT
= 2;
my
$limit
;
my
$lastt
;
sub
new {
my
$class
=
shift
;
my
$site
=
shift
;
my
$apikey
=
shift
;
my
$opts
=
shift
|| {};
return
bless
{
site
=>
$site
,
apikey
=>
$apikey
,
collect_url
=>
$COLLECT_URL
,
event_url
=>
$EVENT_URL
,
%$opts
,
},
$class
;
}
sub
html {
my
$me
=
shift
;
my
$email
=
shift
;
my
$opts
=
shift
;
my
$data
= {
site
=>
$me
->{site},
vers
=>
$VERHASH
};
$data
->{testmode} = JSON::true
if
$opts
->{testmode} ||
$me
->{testmode};
if
( email_valid(
$email
) ){
$email
= trim_space(
$email
);
$data
->{ehlm5} = md5_hex(
lc
$email
);
$data
->{ehum5} = md5_hex(
uc
$email
);
$data
->{ehls1} = sha1_hex(
lc
$email
);
$data
->{ehus1} = sha1_hex(
uc
$email
);
$data
->{ehls2} = sha256_hex(
lc
$email
);
$data
->{ehus2} = sha256_hex(
uc
$email
);
}
my
$url
=
$opts
->{url};
unless
(
$url
){
if
(
$opts
->{use_ssl} ){
$url
=
'https:'
.
$me
->{collect_url};
}
elsif
(
exists
$opts
->{use_ssl} ){
$url
=
'http:'
.
$me
->{collect_url};
}
else
{
$url
=
$me
->{collect_url};
}
}
my
$json
= to_json(
$data
, {
utf8
=> 1,
pretty
=> 1});
my
$html
=
<<EOS;
<script type="text/javascript">
var dd_info = $json
</script>
<script type="text/javascript" src="$url" async></script>
EOS
;
return
$html
;
}
sub
events {
my
$me
=
shift
;
my
$evts
=
shift
;
my
$opts
=
shift
;
return
if
limited();
my
$site
=
$me
->{site};
my
$apikey
=
$me
->{apikey};
my
$url
=
$opts
->{url} ||
$me
->{event_url};
my
$timeout
=
$opts
->{timeout} || (
$TIMEOUT
+
@$evts
/10);
my
$post
= {
site
=>
$site
,
apikey
=>
$apikey
,
vers
=>
$VERHASH
};
$post
->{backfill} = JSON::true
if
$opts
->{backfill};
$post
->{testmode} = JSON::true
if
$opts
->{testmode} ||
$me
->{testmode};
$post
->{events} = [
map
{ fixup_evt(
$_
) }
@$evts
];
my
$req
= HTTP::Request->new(
POST
=>
$url
);
$req
->content_type(
'application/json'
);
$req
->content( to_json(
$post
) );
my
$ua
= LWP::UserAgent->new(
timeout
=>
$timeout
);
my
$res
=
$ua
->request(
$req
);
if
(
$res
->code() == 200 ){
adjust_ok();
return
;
}
adjust_fail();
return
$res
->code() .
" "
.
$res
->content();
}
sub
event {
my
$me
=
shift
;
my
$email
=
shift
;
my
$ip
=
shift
;
my
$event
=
shift
;
my
$additional
=
shift
;
my
$opts
=
shift
;
return
"invalid email"
unless
email_valid(
$email
);
my
%event
;
%event
=
%$additional
if
$additional
;
$event
{email} =
$email
;
$event
{ip} =
$ip
;
$event
{event} =
$event
;
$me
->events( [\
%event
],
$opts
);
}
sub
fixup_evt {
my
$e
=
shift
;
my
%e
=
%$e
;
my
$email
=
$e
{email};
if
( email_valid(
$email
) ){
$email
=
lc
trim_space(
$email
);
$e
{ehls1} = sha1_hex(
$email
);
delete
$e
{email};
unless
(
exists
$e
{email_provider} ){
$e
{email_provider} = (
split
/\@/,
$email
)[1];
}
}
if
( email_valid(
$e
{email_prev}) ){
$e
{ehls1_prev} = sha1_hex(
lc
trim_space(
$e
{email_prev}));
delete
$e
{email_prev};
}
if
(
$e
{cc} ){
my
$cc
=
$e
{cc};
$cc
=~ s/[^0-9]//;
$e
{ccs1} = sha1_hex(
$cc
);
delete
$e
{cc};
}
return
\
%e
;
}
sub
trim_space {
my
$s
=
shift
;
$s
=~ s/^\s+//;
$s
=~ s/\s+$//;
return
$s
;
}
sub
email_valid {
my
$e
=
shift
;
return
$e
=~ /.+\@.+\..+/;
}
sub
limited {
my
$t
=
time
();
$limit
||= 0;
$lastt
||=
$t
;
my
$dt
=
$t
-
$lastt
;
$lastt
=
$t
;
$limit
*= 0.999 **
$dt
;
return
rand
(100) <
$limit
;
}
sub
adjust_ok {
$limit
-= 5;
$limit
= 0
if
$limit
< 0;
}
sub
adjust_fail {
$limit
= (9 *
$limit
+ 100) / 10;
$limit
= 100
if
$limit
> 100;
}
1;