line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::Eboks; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
778
|
use 5.010; |
|
1
|
|
|
|
|
4
|
|
4
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
20
|
|
5
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
28
|
|
6
|
1
|
|
|
1
|
|
5
|
use Encode qw(encode decode); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
57
|
|
7
|
1
|
|
|
1
|
|
896
|
use DateTime; |
|
1
|
|
|
|
|
490788
|
|
|
1
|
|
|
|
|
54
|
|
8
|
1
|
|
|
1
|
|
613
|
use HTTP::Request; |
|
1
|
|
|
|
|
17411
|
|
|
1
|
|
|
|
|
34
|
|
9
|
1
|
|
|
1
|
|
529
|
use Digest::SHA qw(sha256_hex); |
|
1
|
|
|
|
|
2689
|
|
|
1
|
|
|
|
|
80
|
|
10
|
1
|
|
|
1
|
|
876
|
use XML::Simple; |
|
1
|
|
|
|
|
8916
|
|
|
1
|
|
|
|
|
6
|
|
11
|
1
|
|
|
1
|
|
804
|
use LWP::UserAgent; |
|
1
|
|
|
|
|
22188
|
|
|
1
|
|
|
|
|
37
|
|
12
|
1
|
|
|
1
|
|
474
|
use LWP::ConnCache; |
|
1
|
|
|
|
|
1173
|
|
|
1
|
|
|
|
|
32
|
|
13
|
1
|
|
|
1
|
|
743
|
use MIME::Entity; |
|
1
|
|
|
|
|
87737
|
|
|
1
|
|
|
|
|
43
|
|
14
|
1
|
|
|
1
|
|
8
|
use MIME::Base64; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
58
|
|
15
|
1
|
|
|
1
|
|
737
|
use IO::Lambda qw(:all); |
|
1
|
|
|
|
|
14242
|
|
|
1
|
|
|
|
|
238
|
|
16
|
1
|
|
|
1
|
|
497
|
use IO::Lambda::HTTP qw(http_request); |
|
1
|
|
|
|
|
22997
|
|
|
1
|
|
|
|
|
57
|
|
17
|
1
|
|
|
1
|
|
506
|
use Crypt::OpenSSL::RSA; |
|
1
|
|
|
|
|
6736
|
|
|
1
|
|
|
|
|
3993
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our $VERSION = '0.08'; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub new |
22
|
|
|
|
|
|
|
{ |
23
|
0
|
|
|
0
|
0
|
|
my ( $class, %opts ) = @_; |
24
|
0
|
|
|
|
|
|
my $self = bless { |
25
|
|
|
|
|
|
|
cpr => '0000000000', |
26
|
|
|
|
|
|
|
password => '', |
27
|
|
|
|
|
|
|
country => 'DK', |
28
|
|
|
|
|
|
|
type => 'P', |
29
|
|
|
|
|
|
|
datetime => DateTime->now->strftime('%Y-%m-%d %H:%M:%SZ'), |
30
|
|
|
|
|
|
|
root => 'rest.e-boks.dk', |
31
|
|
|
|
|
|
|
deviceid => 'DEADBEEF-1337-1337-1337-900000000002', |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
nonce => '', |
34
|
|
|
|
|
|
|
sessionid => '', |
35
|
|
|
|
|
|
|
response => "3a1a51f235a8bd6bbc29b2caef986a1aeb77018d60ffdad9c5e31117e7b6ead3", # XXX |
36
|
|
|
|
|
|
|
uid => undef, |
37
|
|
|
|
|
|
|
uname => undef, |
38
|
|
|
|
|
|
|
conn_cache => LWP::ConnCache->new, |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
%opts, |
41
|
|
|
|
|
|
|
}, $class; |
42
|
|
|
|
|
|
|
|
43
|
0
|
|
|
|
|
|
return $self; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub response |
47
|
|
|
|
|
|
|
{ |
48
|
0
|
|
|
0
|
0
|
|
my ($self, $decode, $response) = @_; |
49
|
|
|
|
|
|
|
|
50
|
0
|
0
|
|
|
|
|
unless ($response->is_success) { |
51
|
0
|
|
0
|
|
|
|
my $sl = $response->message // $response-> status_line; |
52
|
0
|
|
|
|
|
|
chomp $sl; |
53
|
0
|
|
|
|
|
|
$sl =~ s/\+/ /g; |
54
|
0
|
|
|
|
|
|
return undef, $sl; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
0
|
|
|
|
|
|
for ( split /,\s*/, $response->header('x-eboks-authenticate')) { |
58
|
0
|
0
|
|
|
|
|
warn "bad x-eboks-authenticate: $_\n" unless m/^(sessionid|nonce)="(.*?)"$/; |
59
|
0
|
|
|
|
|
|
$self->{$1} = $2; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
0
|
0
|
|
|
|
|
return $response->decoded_content unless $decode; |
63
|
|
|
|
|
|
|
|
64
|
0
|
0
|
|
|
|
|
my %options = ref($decode) ? %$decode : (); |
65
|
0
|
|
|
|
|
|
my $content = $response->decoded_content; |
66
|
0
|
0
|
0
|
|
|
|
if ( $content !~ /[^\x00-\xff]/ && $content =~ /[\x80-\xff]/ ) { |
67
|
|
|
|
|
|
|
# try to upgrade |
68
|
0
|
|
|
|
|
|
eval { |
69
|
0
|
|
|
|
|
|
my $c = decode('latin1', $content); |
70
|
0
|
|
|
|
|
|
$content = $c; |
71
|
|
|
|
|
|
|
}; |
72
|
|
|
|
|
|
|
} |
73
|
0
|
|
|
|
|
|
my $xml = XMLin($content, ForceArray => 1, %options); |
74
|
0
|
0
|
0
|
|
|
|
if ( $xml && ref($xml) eq 'HASH' ) { |
75
|
0
|
|
|
|
|
|
return $xml; |
76
|
|
|
|
|
|
|
} else { |
77
|
0
|
|
|
|
|
|
return undef, "xml returned is not a hash"; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub login |
82
|
|
|
|
|
|
|
{ |
83
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
84
|
|
|
|
|
|
|
|
85
|
0
|
0
|
|
|
|
|
return undef if defined $self->{uid}; |
86
|
|
|
|
|
|
|
|
87
|
0
|
|
|
|
|
|
local $self->{challenge} = sha256_hex(sha256_hex(join(':', EBOKS => @{$self}{ |
88
|
0
|
|
|
|
|
|
qw(deviceid type cpr country password datetime)}))); |
89
|
0
|
|
|
|
|
|
my $authstr = 'logon ' . join(',', map { "$_=\"$self->{$_}\"" } qw(deviceid datetime challenge)); |
|
0
|
|
|
|
|
|
|
90
|
0
|
|
|
|
|
|
my $content = <<XML; |
91
|
|
|
|
|
|
|
<Logon xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" |
92
|
|
|
|
|
|
|
xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns="urn:eboks:mobile:1.0.0"> |
93
|
|
|
|
|
|
|
<User identity="$self->{cpr}" identityType="$self->{type}" |
94
|
|
|
|
|
|
|
nationality="$self->{country}" pincode="$self->{password}"/> |
95
|
|
|
|
|
|
|
</Logon> |
96
|
|
|
|
|
|
|
XML |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
my $login = HTTP::Request->new( |
99
|
|
|
|
|
|
|
'PUT', |
100
|
|
|
|
|
|
|
'https://' . $self->{root} . '/mobile/1/xml.svc/en-gb/session', |
101
|
|
|
|
|
|
|
[ |
102
|
|
|
|
|
|
|
'Content-Type' => 'application/xml', |
103
|
|
|
|
|
|
|
'Content-Length' => length($content), |
104
|
|
|
|
|
|
|
'X-EBOKS-AUTHENTICATE' => $authstr, |
105
|
|
|
|
|
|
|
'Accept' => '*/*', |
106
|
|
|
|
|
|
|
'Accept-Language' => 'en-US', |
107
|
|
|
|
|
|
|
'Accept-Encoding' => 'gzip,deflate', |
108
|
|
|
|
|
|
|
'Host' => $self->{root}, |
109
|
0
|
|
|
|
|
|
], |
110
|
|
|
|
|
|
|
$content |
111
|
|
|
|
|
|
|
); |
112
|
0
|
|
|
|
|
|
$login->protocol('HTTP/1.1'); |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
return $login, sub { |
115
|
0
|
|
|
0
|
|
|
my ($xml, $error) = $self-> response({ForceArray => 0}, @_); |
116
|
0
|
0
|
|
|
|
|
return $xml, $error unless $xml; |
117
|
0
|
0
|
|
|
|
|
return undef, "'User' is not present in response" unless exists $xml->{User}; |
118
|
|
|
|
|
|
|
|
119
|
0
|
|
|
|
|
|
$self->{uid} = $xml->{User}->{userId}; |
120
|
0
|
|
|
|
|
|
$self->{uname} = $xml->{User}->{name}; |
121
|
0
|
|
|
|
|
|
return $self->{uname}; |
122
|
0
|
|
|
|
|
|
}; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub login_nemid |
126
|
|
|
|
|
|
|
{ |
127
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
128
|
|
|
|
|
|
|
|
129
|
0
|
0
|
|
|
|
|
return undef if defined $self->{uid}; |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# openssl genrsa -out id_rsa 2048 |
132
|
0
|
|
|
|
|
|
my $pk = Crypt::OpenSSL::RSA->new_private_key(<<'PVT'); |
133
|
|
|
|
|
|
|
-----BEGIN RSA PRIVATE KEY----- |
134
|
|
|
|
|
|
|
MIIEpAIBAAKCAQEA2VUahnbWKIY4rn8jEthY9M2BoMIHoNQlY4YUL9pV+MpSKyy9 |
135
|
|
|
|
|
|
|
MjVKV6h8ERnj+1wxUJDR3ZJimYnvcruGqlSR+uhL8MJs7GqSSOL3zKbZiHmip1/j |
136
|
|
|
|
|
|
|
/9Wzsu86VJibxd14/5r8OugIJDs+aeE6fxpKW1BtUiiUAvlbC4MwnAnCPemzl7gG |
137
|
|
|
|
|
|
|
qi64xsSaVdoi0NzZpxI+ItP9x89eMw64F5GlIviGJ9hODyW3ckKSvgxEQGf7x9TN |
138
|
|
|
|
|
|
|
toVt1Gxh4jdokalHmgNQy4zaqnzGLstl227HIEfbbzX/rK30FFVurFG0JAE9T7z7 |
139
|
|
|
|
|
|
|
b0S5RkGFx4GgKGRoFRd8HE+UptBa4JyvmvA3MQIDAQABAoIBAQCtEkbDWhOFxg2R |
140
|
|
|
|
|
|
|
eJGXyk5c9OMMADhO7WKw9O9ShE7+hzAUTdaFC0ces3/JppKVc3+aJxnZl1+J4fyb |
141
|
|
|
|
|
|
|
o5bEQgDWjPMc0dgoFV5VSNoJUb3eHu9W1tgcvjQShMww3i7+zTY0Z1oCFxGUuNEl |
142
|
|
|
|
|
|
|
REVvPqKEQXItgT8Nd0H30wt815Cl9+RlaXMmNRq6aCB0GSUHpVGmgasiUejk7Zej |
143
|
|
|
|
|
|
|
rp23LarcmZitiQXGt0yCbW35/6553Ph88W4cgfav6y+LKTxK06UkKh/QRJaCoKLV |
144
|
|
|
|
|
|
|
BXVmb5HCZv5waU5eRaxV/TKTATDU45DuU3f76+OlQp0P/cH4EVXhC+95fLJ1XUxG |
145
|
|
|
|
|
|
|
lSIQW+MhAoGBAO7N0o5llwbgNpxzZ6z4mRni3LUFpURozNT3q616qM7QGBRfDeHI |
146
|
|
|
|
|
|
|
o1cZf8wRWmMBdA16iWT7xMTpRfHcHt8NW+XlzisQG5KOlrUh1ZtRrltFGPnxUd84 |
147
|
|
|
|
|
|
|
EgbUK+ArzU4mqZZMETZBmrJqVO1lB0dhrjqZ9SDUeXimNqZCoGHU/Z9VAoGBAOj7 |
148
|
|
|
|
|
|
|
d/bhp4OtRKBDgKF1IThikgnsZAcBfGCXaASrPFAbi1p4MNEHUNkQXG7V/PSxMlUf |
149
|
|
|
|
|
|
|
y3U35Hsxexpq2Al98gw/TUBdgb/WfDJHole1fbXTd/Gh9H8RdMLSnOdLTCMXvW9r |
150
|
|
|
|
|
|
|
e1DKt8/5fb87BE8xQUc9sXJ5mmx522WqEyOXZeBtAoGAbIUQCDHWXgOKDbLMDGi0 |
151
|
|
|
|
|
|
|
enUDwyeboOjXHHiohZ9WExWxu6AumMoqoCwwTTYdkxxX9sAWq9NV6f3wESbsyIQz |
152
|
|
|
|
|
|
|
nNe/xwX84a72gb2sanbF+yf9X6fwgrXiS0Qj5C1DkR40tt4+fB94A1ga2/6rPh7/ |
153
|
|
|
|
|
|
|
pBXOtWqZAODXuNpSM+MsljkCgYBWV9u9wyMxyaUFP/8L1zzYiK9WviTT89kEcxg5 |
154
|
|
|
|
|
|
|
orxXc93RSXnN/cgYqdeXu/ZjOMhOg9oDNxOWFGBrCe3GlsZ9g3g9wmmzjum4OJQR |
155
|
|
|
|
|
|
|
rVFJcXWiN0NFVFLRYPyFO4Kb/tBV2p948afti6julhCiyL5IiLSamDaCvSZyJvWw |
156
|
|
|
|
|
|
|
2wsGgQKBgQCt6ityOP56Co60pUnhonmNLg98IvWnREn8xoGdjtrMuk+Ksf5sUX5i |
157
|
|
|
|
|
|
|
fcogYnJ4ciLmJ37cVXfOtrRrDsjqSbHY07Oqb0qdIKPATJkiK0ltXG4hSvjB2LPU |
158
|
|
|
|
|
|
|
XC53Clpk+n6+ltUJnUAFtl8g4jcUG9Bs+334WiX0n7Hx7yQlsvzBtA== |
159
|
|
|
|
|
|
|
-----END RSA PRIVATE KEY----- |
160
|
|
|
|
|
|
|
PVT |
161
|
0
|
|
|
|
|
|
local $self->{challenge} = join(':', q(EBOKS), @{$self}{qw(deviceid type cpr country password datetime)}); |
|
0
|
|
|
|
|
|
|
162
|
0
|
|
|
|
|
|
$self->{challenge} = encode_base64($pk->sign($self->{challenge})); |
163
|
|
|
|
|
|
|
|
164
|
0
|
|
|
|
|
|
my $authstr = 'logon ' . join(',', map { "$_=\"$self->{$_}\"" } qw(deviceid datetime challenge)); |
|
0
|
|
|
|
|
|
|
165
|
0
|
|
|
|
|
|
my $content = <<XML; |
166
|
|
|
|
|
|
|
<Logon xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" |
167
|
|
|
|
|
|
|
xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns="urn:eboks:mobile:1.0.0"> |
168
|
|
|
|
|
|
|
<App version="$VERSION" os="$^O" osVersion="1" Device="Net-Eboks"/> |
169
|
|
|
|
|
|
|
<User identity="$self->{cpr}" identityType="$self->{type}" |
170
|
|
|
|
|
|
|
nationality="$self->{country}" pincode="$self->{password}"/> |
171
|
|
|
|
|
|
|
</Logon> |
172
|
|
|
|
|
|
|
XML |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
my $login = HTTP::Request->new( |
175
|
|
|
|
|
|
|
'PUT', |
176
|
|
|
|
|
|
|
'https://' . $self->{root} . '/mobile/1/xml.svc/en-gb/session', |
177
|
|
|
|
|
|
|
[ |
178
|
|
|
|
|
|
|
'Content-Type' => 'application/xml', |
179
|
|
|
|
|
|
|
'Content-Length' => length($content), |
180
|
|
|
|
|
|
|
'X-EBOKS-AUTHENTICATE' => $authstr, |
181
|
|
|
|
|
|
|
'Accept' => '*/*', |
182
|
|
|
|
|
|
|
'Accept-Language' => 'en-US', |
183
|
|
|
|
|
|
|
'Accept-Encoding' => 'gzip,deflate', |
184
|
|
|
|
|
|
|
'Host' => $self->{root}, |
185
|
0
|
|
|
|
|
|
], |
186
|
|
|
|
|
|
|
$content |
187
|
|
|
|
|
|
|
); |
188
|
0
|
|
|
|
|
|
$login->protocol('HTTP/1.1'); |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
return $login, sub { |
191
|
0
|
|
|
0
|
|
|
my ($xml, $error) = $self-> response({ForceArray => 0}, @_); |
192
|
0
|
0
|
|
|
|
|
return $xml, $error unless $xml; |
193
|
0
|
0
|
|
|
|
|
return undef, "'User' is not present in response" unless exists $xml->{User}; |
194
|
|
|
|
|
|
|
|
195
|
0
|
|
|
|
|
|
$self->{uid} = $xml->{User}->{userId}; |
196
|
0
|
|
|
|
|
|
$self->{uname} = $xml->{User}->{name}; |
197
|
0
|
|
|
|
|
|
return $self->{uname}; |
198
|
0
|
|
|
|
|
|
}; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub session_activate |
202
|
|
|
|
|
|
|
{ |
203
|
0
|
|
|
0
|
0
|
|
my ($self, $ticket) = @_; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# openssl rsa -in id_rsa -outform PEM -pubout -out id_rsa.pub |
206
|
0
|
|
|
|
|
|
my $pubkey = join '', grep {!/^--/} split /\n/, <<'PUB'; |
|
0
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
-----BEGIN PUBLIC KEY----- |
208
|
|
|
|
|
|
|
MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA2VUahnbWKIY4rn8jEthY |
209
|
|
|
|
|
|
|
9M2BoMIHoNQlY4YUL9pV+MpSKyy9MjVKV6h8ERnj+1wxUJDR3ZJimYnvcruGqlSR |
210
|
|
|
|
|
|
|
+uhL8MJs7GqSSOL3zKbZiHmip1/j/9Wzsu86VJibxd14/5r8OugIJDs+aeE6fxpK |
211
|
|
|
|
|
|
|
W1BtUiiUAvlbC4MwnAnCPemzl7gGqi64xsSaVdoi0NzZpxI+ItP9x89eMw64F5Gl |
212
|
|
|
|
|
|
|
IviGJ9hODyW3ckKSvgxEQGf7x9TNtoVt1Gxh4jdokalHmgNQy4zaqnzGLstl227H |
213
|
|
|
|
|
|
|
IEfbbzX/rK30FFVurFG0JAE9T7z7b0S5RkGFx4GgKGRoFRd8HE+UptBa4JyvmvA3 |
214
|
|
|
|
|
|
|
MQIDAQAB |
215
|
|
|
|
|
|
|
-----END PUBLIC KEY----- |
216
|
|
|
|
|
|
|
PUB |
217
|
|
|
|
|
|
|
|
218
|
0
|
|
|
|
|
|
my $authstr = join(',', map { "$_=\"$self->{$_}\"" } qw(deviceid nonce sessionid response)); |
|
0
|
|
|
|
|
|
|
219
|
0
|
|
|
|
|
|
my $content = <<XML; |
220
|
|
|
|
|
|
|
<?xml version="1.0" encoding="utf-8"?> |
221
|
|
|
|
|
|
|
<Activation xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" |
222
|
|
|
|
|
|
|
xmlns:xsd="http://www.w3.org/2001/XMLSchema" deviceId="$self->{deviceid}" |
223
|
|
|
|
|
|
|
deviceName="Net-Eboks" deviceOs="$^O" key="$pubkey" ticket="$ticket" |
224
|
|
|
|
|
|
|
ticketType="KspWeb" xmlns="urn:eboks:mobile:1.0.0" /> |
225
|
|
|
|
|
|
|
XML |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
my $login = HTTP::Request->new( |
228
|
|
|
|
|
|
|
'PUT', |
229
|
|
|
|
|
|
|
'https://' . $self->{root} . "/mobile/1/xml.svc/en-gb/$self->{uid}/0/session/activate", |
230
|
|
|
|
|
|
|
[ |
231
|
|
|
|
|
|
|
'Content-Type' => 'application/xml', |
232
|
|
|
|
|
|
|
'Content-Length' => length($content), |
233
|
|
|
|
|
|
|
'X-EBOKS-AUTHENTICATE' => $authstr, |
234
|
|
|
|
|
|
|
'Accept' => '*/*', |
235
|
|
|
|
|
|
|
'Accept-Language' => 'en-US', |
236
|
|
|
|
|
|
|
'Accept-Encoding' => 'gzip,deflate', |
237
|
|
|
|
|
|
|
'Host' => $self->{root}, |
238
|
0
|
|
|
|
|
|
], |
239
|
|
|
|
|
|
|
$content |
240
|
|
|
|
|
|
|
); |
241
|
0
|
|
|
|
|
|
$login->protocol('HTTP/1.1'); |
242
|
|
|
|
|
|
|
|
243
|
0
|
|
|
0
|
|
|
return $login, sub { $self-> response(0, @_) }; |
|
0
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
0
|
|
|
0
|
0
|
|
sub ua { LWP::UserAgent->new(conn_cache => shift->{conn_cache}) } |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
sub get |
249
|
|
|
|
|
|
|
{ |
250
|
0
|
|
|
0
|
0
|
|
my ($self, $path) = @_; |
251
|
0
|
|
|
|
|
|
my $authstr = join(',', map { "$_=\"$self->{$_}\"" } qw(deviceid nonce sessionid response)); |
|
0
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
my $get = HTTP::Request->new( |
253
|
|
|
|
|
|
|
'GET', |
254
|
|
|
|
|
|
|
'https://' . $self->{root} . '/' . $path, |
255
|
|
|
|
|
|
|
[ |
256
|
|
|
|
|
|
|
'X-EBOKS-AUTHENTICATE' => $authstr, |
257
|
|
|
|
|
|
|
'Accept' => '*/*', |
258
|
|
|
|
|
|
|
'Accept-Language' => 'en-US', |
259
|
|
|
|
|
|
|
'Host' => $self->{root}, |
260
|
0
|
|
|
|
|
|
], |
261
|
|
|
|
|
|
|
); |
262
|
0
|
|
|
|
|
|
$get->protocol('HTTP/1.1'); |
263
|
0
|
|
|
|
|
|
return $get; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
sub xmlget |
267
|
|
|
|
|
|
|
{ |
268
|
0
|
|
|
0
|
0
|
|
my ( $self, $uri, $path, %xmlopt ) = @_; |
269
|
|
|
|
|
|
|
return |
270
|
|
|
|
|
|
|
$self->get($uri), sub { |
271
|
0
|
|
|
0
|
|
|
my ($xml, $error) = $self-> response(\%xmlopt, @_); |
272
|
0
|
0
|
|
|
|
|
return $xml, $error unless $xml; |
273
|
0
|
|
0
|
|
|
|
for my $step ( @{ $path // [] } ) { |
|
0
|
|
|
|
|
|
|
274
|
0
|
0
|
|
|
|
|
return undef, "key '$step' not found" unless ref $xml; |
275
|
0
|
0
|
|
|
|
|
if ( ref($xml) eq 'ARRAY') { |
276
|
0
|
|
|
|
|
|
$xml = $xml->[$step]; |
277
|
|
|
|
|
|
|
} else { |
278
|
0
|
|
|
|
|
|
$xml = $xml->{$step}; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
0
|
|
0
|
|
|
|
my $key = $xmlopt{KeyAttr} // 'name'; |
283
|
0
|
|
|
|
|
|
while ( my ( $k, $v ) = each %$xml ) { |
284
|
0
|
0
|
0
|
|
|
|
$v->{$key} = $k if defined($v) && ref($v) eq 'HASH'; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
0
|
|
|
|
|
|
return $xml; |
288
|
0
|
|
|
|
|
|
}; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
sub folders |
292
|
|
|
|
|
|
|
{ |
293
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
294
|
0
|
0
|
|
|
|
|
return undef unless $self->{uid}; |
295
|
0
|
|
|
|
|
|
$self-> xmlget("/mobile/1/xml.svc/en-gb/$self->{uid}/0/mail/folders", ['FolderInfo']); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub messages |
299
|
|
|
|
|
|
|
{ |
300
|
0
|
|
|
0
|
0
|
|
my ($self, $folder_id, $offset, $limit) = @_; |
301
|
0
|
0
|
|
|
|
|
return undef unless $self->{uid}; |
302
|
0
|
|
0
|
|
|
|
$limit //= 1; |
303
|
0
|
|
0
|
|
|
|
$offset //= 0; |
304
|
0
|
|
|
|
|
|
$self-> xmlget( |
305
|
|
|
|
|
|
|
"/mobile/1/xml.svc/en-gb/$self->{uid}/0/mail/folder/$folder_id?skip=$offset&take=$limit", |
306
|
|
|
|
|
|
|
[ qw(Messages 0 MessageInfo) ], |
307
|
|
|
|
|
|
|
KeyAttr => 'id' |
308
|
|
|
|
|
|
|
); |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub message |
312
|
|
|
|
|
|
|
{ |
313
|
0
|
|
|
0
|
0
|
|
my ($self, $folder_id, $message_id) = @_; |
314
|
0
|
0
|
|
|
|
|
return undef unless $self->{uid}; |
315
|
0
|
|
|
|
|
|
$self-> xmlget( |
316
|
|
|
|
|
|
|
"/mobile/1/xml.svc/en-gb/$self->{uid}/0/mail/folder/$folder_id/message/$message_id", |
317
|
|
|
|
|
|
|
[], |
318
|
|
|
|
|
|
|
KeyAttr => 'id' |
319
|
|
|
|
|
|
|
); |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
sub content |
323
|
|
|
|
|
|
|
{ |
324
|
0
|
|
|
0
|
0
|
|
my ( $self, $folder_id, $content_id ) = @_; |
325
|
|
|
|
|
|
|
return |
326
|
|
|
|
|
|
|
$self-> get( "/mobile/1/xml.svc/en-gb/$self->{uid}/0/mail/folder/$folder_id/message/$content_id/content" ), sub { |
327
|
0
|
|
|
0
|
|
|
$self-> response( 0, @_ ) |
328
|
0
|
|
|
|
|
|
}; |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
0
|
|
|
0
|
0
|
|
sub attachments { $_[1]->{Attachements}->[0]->{AttachmentInfo} } |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub filename { |
334
|
0
|
|
|
0
|
0
|
|
my $fn = $_[1]-> {name}; |
335
|
0
|
|
|
|
|
|
$fn =~ s[:\\\/][_]; |
336
|
0
|
|
|
|
|
|
my $fmt = lc($_[1]->{format}); |
337
|
0
|
0
|
|
|
|
|
$fmt = 'txt' if $fmt eq 'plain'; |
338
|
|
|
|
|
|
|
return $fn . '.' .lc($_[1]->{format}) |
339
|
0
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub mime_type |
342
|
|
|
|
|
|
|
{ |
343
|
0
|
|
|
0
|
0
|
|
my $fmt = lc $_[1]->{format}; |
344
|
0
|
0
|
|
|
|
|
if ( $fmt =~ /^(pdf)$/ ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
345
|
0
|
|
|
|
|
|
return "application/$fmt"; |
346
|
|
|
|
|
|
|
} elsif ( $fmt =~ /^(gif|jpg|jpeg|tiff|png|webp)$/) { |
347
|
0
|
|
|
|
|
|
return "image/$fmt"; |
348
|
|
|
|
|
|
|
} elsif ( $fmt =~ /^(txt|text|html|plain)$/) { |
349
|
0
|
0
|
|
|
|
|
$fmt = 'plain' if $fmt =~ /^(txt|text)$/; |
350
|
0
|
|
|
|
|
|
return "text/$fmt"; |
351
|
|
|
|
|
|
|
} else { |
352
|
0
|
|
|
|
|
|
return "application/$fmt"; |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
sub first_value |
357
|
|
|
|
|
|
|
{ |
358
|
0
|
|
|
0
|
0
|
|
my ($self, $entry) = @_; |
359
|
0
|
0
|
|
|
|
|
if ( ref($entry) eq 'HASH') { |
|
|
0
|
|
|
|
|
|
360
|
0
|
|
|
|
|
|
my $k = (sort keys %$entry)[0]; |
361
|
0
|
|
|
|
|
|
return $entry->{$k}; |
362
|
|
|
|
|
|
|
} elsif ( ref($entry) eq 'ARRAY') { |
363
|
0
|
|
|
|
|
|
return $entry->[0]; |
364
|
|
|
|
|
|
|
} else { |
365
|
0
|
|
|
|
|
|
return "bad entry"; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
sub safe_encode |
370
|
|
|
|
|
|
|
{ |
371
|
0
|
|
|
0
|
0
|
|
my ($enc, $text) = @_; |
372
|
0
|
|
|
|
|
|
utf8::downgrade($text, 'fail silently please'); |
373
|
0
|
0
|
0
|
|
|
|
return (utf8::is_utf8($text) || $text =~ /[\x80-\xff]/) ? encode($enc, $text) : $text; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
sub assemble_mail |
377
|
|
|
|
|
|
|
{ |
378
|
0
|
|
|
0
|
0
|
|
my ( $self, %opt ) = @_; |
379
|
|
|
|
|
|
|
|
380
|
0
|
|
|
|
|
|
my $msg = $opt{message}; |
381
|
0
|
|
|
|
|
|
my $sender = $self->first_value($msg->{Sender}); |
382
|
0
|
0
|
|
|
|
|
$sender = $sender->{content} if ref($sender) eq 'HASH'; |
383
|
0
|
|
0
|
|
|
|
$sender //= 'unknown'; |
384
|
|
|
|
|
|
|
|
385
|
0
|
|
0
|
|
|
|
my $received = $msg->{receivedDateTime} // ''; |
386
|
0
|
|
|
|
|
|
my $date; |
387
|
0
|
0
|
|
|
|
|
if ( $received =~ /^(\d{4})-(\d{2})-(\d{2})T(\d\d):(\d\d):(\d\d)/) { |
388
|
0
|
|
|
|
|
|
$date = DateTime->new( |
389
|
|
|
|
|
|
|
year => $1, |
390
|
|
|
|
|
|
|
month => $2, |
391
|
|
|
|
|
|
|
day => $3, |
392
|
|
|
|
|
|
|
hour => $4, |
393
|
|
|
|
|
|
|
minute => $5, |
394
|
|
|
|
|
|
|
second => $6, |
395
|
|
|
|
|
|
|
); |
396
|
|
|
|
|
|
|
} else { |
397
|
0
|
|
|
|
|
|
$date = DateTime->now; |
398
|
|
|
|
|
|
|
} |
399
|
0
|
|
|
|
|
|
$received = $date->strftime('%a, %d %b %Y %H:%M:%S %z'); |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
my $mail = MIME::Entity->build( |
402
|
|
|
|
|
|
|
From => $opt{from} // ( safe_encode('MIME-Q', $sender) . ' <noreply@e-boks.dk>' ) , |
403
|
|
|
|
|
|
|
To => $opt{to} // ( safe_encode('MIME-Q', $self->{uname}) . ' <' . ( $ENV{USER} // 'you' ) . '@localhost>' ), |
404
|
|
|
|
|
|
|
Subject => $opt{subject} // safe_encode('MIME-Header', $msg->{name}), |
405
|
|
|
|
|
|
|
Data => $opt{data} // encode('utf-8', "Mail from $sender"), |
406
|
0
|
|
0
|
|
|
|
Date => $opt{date} // $received, |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
407
|
|
|
|
|
|
|
Charset => 'utf-8', |
408
|
|
|
|
|
|
|
Encoding => 'quoted-printable', |
409
|
|
|
|
|
|
|
'X-Net-Eboks' => "v/$VERSION", |
410
|
|
|
|
|
|
|
); |
411
|
|
|
|
|
|
|
|
412
|
0
|
|
|
|
|
|
my @attachments; |
413
|
0
|
0
|
|
|
|
|
push @attachments, [ $msg, $opt{body} ] if exists $opt{body}; |
414
|
|
|
|
|
|
|
|
415
|
0
|
|
|
|
|
|
my $attachments = $self->attachments($msg); |
416
|
0
|
|
|
|
|
|
for my $att_id ( sort keys %$attachments ) { |
417
|
0
|
|
|
|
|
|
push @attachments, [ $attachments->{$att_id}, $opt{attachments}->{$att_id} ]; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
0
|
|
|
|
|
|
for ( @attachments ) { |
421
|
0
|
|
|
|
|
|
my ( $msg, $body ) = @$_; |
422
|
0
|
|
|
|
|
|
my $fn = $self->filename($msg); |
423
|
0
|
|
|
|
|
|
Encode::_utf8_off($body); |
424
|
0
|
|
|
|
|
|
my $entity = $mail->attach( |
425
|
|
|
|
|
|
|
Type => $self->mime_type($msg), |
426
|
|
|
|
|
|
|
Encoding => 'base64', |
427
|
|
|
|
|
|
|
Data => $body, |
428
|
|
|
|
|
|
|
Filename => $fn, |
429
|
|
|
|
|
|
|
); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
# XXX hack filename for utf8 |
432
|
0
|
0
|
|
|
|
|
next unless $fn =~ m/[^\x00-\x80]/; |
433
|
0
|
|
|
|
|
|
$fn = Encode::encode('MIME-B', $fn); |
434
|
0
|
|
|
|
|
|
for ( 'Content-disposition', 'Content-type') { |
435
|
0
|
|
|
|
|
|
my $v = $entity->head->get($_); |
436
|
0
|
|
|
|
|
|
$v =~ s/name="(.*)"/name="$fn"/; |
437
|
0
|
|
|
|
|
|
$entity->head->replace($_, $v); |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
return |
442
|
0
|
|
|
|
|
|
'From noreply@localhost ' . |
443
|
|
|
|
|
|
|
$date->strftime('%a %b %d %H:%M:%S %Y') . "\n" . |
444
|
|
|
|
|
|
|
$mail->stringify |
445
|
|
|
|
|
|
|
; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
sub fetch_request |
449
|
|
|
|
|
|
|
{ |
450
|
0
|
|
|
0
|
0
|
|
my ($self, $request, $callback) = @_; |
451
|
0
|
0
|
|
0
|
|
|
return lambda { undef, "bad request" } unless $request; |
|
0
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
return lambda { |
453
|
|
|
|
|
|
|
context $request, |
454
|
|
|
|
|
|
|
conn_cache => $self->{conn_cache}, #XXX |
455
|
0
|
|
|
0
|
|
|
keep_alive => 1; #XXX |
456
|
|
|
|
|
|
|
http_request { |
457
|
0
|
|
|
|
|
|
my $response = shift; |
458
|
0
|
0
|
|
|
|
|
return undef, $response unless ref $response; |
459
|
0
|
|
|
|
|
|
return $callback->($response); |
460
|
0
|
|
|
|
|
|
}}; |
|
0
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
sub fetch_message_and_attachments |
464
|
|
|
|
|
|
|
{ |
465
|
0
|
|
|
0
|
0
|
|
my ($self, $message ) = @_; |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
return lambda { |
468
|
0
|
|
|
0
|
|
|
context $self-> fetch_request( $self->message( $message->{folderId}, $message->{id} ) ); |
469
|
|
|
|
|
|
|
tail { |
470
|
0
|
|
|
|
|
|
my ($xml, $error) = @_; |
471
|
0
|
0
|
|
|
|
|
return ($xml, $error) unless defined $xml; |
472
|
|
|
|
|
|
|
|
473
|
0
|
|
|
|
|
|
my $attachments = $self-> attachments( $xml ); |
474
|
0
|
|
|
|
|
|
my @attachments = keys %$attachments; |
475
|
0
|
|
|
|
|
|
my %opt = ( |
476
|
|
|
|
|
|
|
message => $xml, |
477
|
|
|
|
|
|
|
attachments => {}, |
478
|
|
|
|
|
|
|
); |
479
|
|
|
|
|
|
|
|
480
|
0
|
|
|
|
|
|
context $self-> fetch_request( $self-> content( $message->{folderId}, $message->{id} )); |
481
|
|
|
|
|
|
|
tail { |
482
|
0
|
|
|
|
|
|
my ($body, $error) = @_; |
483
|
0
|
0
|
|
|
|
|
return ($body, $error) unless defined $body; |
484
|
0
|
|
|
|
|
|
$opt{body} = $body; |
485
|
|
|
|
|
|
|
|
486
|
0
|
0
|
|
|
|
|
my $att_id = shift @attachments or return \%opt; |
487
|
0
|
|
|
|
|
|
context $self-> fetch_request( $self-> content( $message->{folderId}, $att_id )); |
488
|
|
|
|
|
|
|
tail { |
489
|
0
|
|
|
|
|
|
my ($att_body, $error) = @_; |
490
|
0
|
0
|
|
|
|
|
return ($att_body, $error) unless defined $att_body; |
491
|
|
|
|
|
|
|
|
492
|
0
|
|
|
|
|
|
$opt{attachments}->{$att_id} = $att_body; |
493
|
0
|
0
|
|
|
|
|
$att_id = shift @attachments or return \%opt; |
494
|
0
|
|
|
|
|
|
context $self-> fetch_request( $self-> content( $message->{folderId}, $att_id )); |
495
|
0
|
|
|
|
|
|
again; |
496
|
0
|
|
|
|
|
|
}}}}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
sub list_all_messages |
500
|
|
|
|
|
|
|
{ |
501
|
0
|
|
|
0
|
0
|
|
my ( $self, $folder_id ) = @_; |
502
|
|
|
|
|
|
|
|
503
|
0
|
|
|
|
|
|
my $offset = 0; |
504
|
0
|
|
|
|
|
|
my $limit = 1000; |
505
|
|
|
|
|
|
|
|
506
|
0
|
|
|
|
|
|
my %ret; |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
return lambda { |
509
|
0
|
|
|
0
|
|
|
context $self-> fetch_request( $self-> messages( $folder_id, $offset, $limit )); |
510
|
|
|
|
|
|
|
tail { |
511
|
0
|
|
|
|
|
|
my ($xml, $error) = @_; |
512
|
0
|
0
|
|
|
|
|
return ($xml, $error) unless $xml; |
513
|
|
|
|
|
|
|
|
514
|
0
|
|
|
|
|
|
%ret = ( %ret, %$xml ); |
515
|
|
|
|
|
|
|
#delete $ret{0}; # generates 500 server error |
516
|
0
|
0
|
|
|
|
|
return \%ret if keys(%$xml) < $limit; |
517
|
|
|
|
|
|
|
|
518
|
0
|
|
|
|
|
|
$offset += $limit; |
519
|
0
|
|
|
|
|
|
context $self-> fetch_request( $self-> messages( $folder_id, $offset, $limit )); |
520
|
0
|
|
|
|
|
|
again; |
521
|
0
|
|
|
|
|
|
}}; |
|
0
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
1; |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
__DATA__ |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
=pod |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
=head1 NAME |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
Net::Eboks - perl API for http://eboks.dk/ |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
=head1 DESCRIPTION |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
Read-only interface for eboks. See README for more info. |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
=head1 AUTHOR |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
Dmitry Karasik <dmitry@karasik.eu.org> |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
=cut |