1package OpenXPKI::Client::UI::Request;
2
3use Moose;
4use namespace::autoclean;
5
6# Core modules
7use Data::Dumper;
8use MIME::Base64;
9use Carp qw( confess );
10
11# CPAN modules
12use JSON;
13use Log::Log4perl;
14use Crypt::JWT qw( decode_jwt );
15use Moose::Util::TypeConstraints;
16
17
18has cgi => (
19    required => 1,
20    is => 'ro',
21    isa => duck_type( [qw( param multi_param content_type )] ), # not "isa => 'CGI'" as we use CGIMock in tests
22);
23
24has session => (
25    required => 1,
26    is => 'rw',
27    isa => 'CGI::Session',
28);
29
30has cache => (
31    is => 'rw',
32    isa => 'HashRef',
33    default => sub { return {}; }
34);
35
36has method => (
37    is => 'rw',
38    isa => 'Str',
39    default => 'GET',
40);
41
42has logger => (
43    is => 'ro',
44    isa => 'Log::Log4perl::Logger',
45    lazy => 1,
46    default => sub { return Log::Log4perl->get_logger; }
47);
48
49has _prefix_base64 => (
50    is => 'ro',
51    isa => 'Str',
52    default => '_encoded_base64_',
53);
54
55has _prefix_jwt => (
56    is => 'ro',
57    isa => 'Str',
58    default => '_encrypted_jwt_',
59);
60
61sub BUILD {
62
63    my $self = shift;
64
65    #
66    # Preset all keys in the cache (for JSON data, also set the values)
67    #
68    my %cache;
69
70    # store keys from CGI params
71    my @keys = $self->cgi->param;
72    $cache{$_} = undef for @keys;
73    do { $self->logger->debug(sprintf('CGI param: %s=%s', $_, join(',', $self->cgi->multi_param($_)))) for $self->cgi->param } if $self->logger->is_debug;
74
75    # store keys and values from JSON POST data
76    if (($self->cgi->content_type // '') eq 'application/json') {
77        $self->logger->debug('Incoming POST data in JSON format (application/json)');
78
79        my $json = JSON->new->utf8;
80        my $data = $json->decode( scalar $self->cgi->param('POSTDATA') );
81
82        # Resolve stringified depth-one-hashes - turn parameters like
83        #   key{one} = 34
84        #   key{two} = 56
85        # into a HashRef
86        #   key => { one => 34, two => 56 }
87        foreach my $combined_key (keys %$data) {
88            if (my ($key, $subkey) = $combined_key =~ m{ \A (\w+)\{(\w+)\} \z }xs) {
89                $data->{$key} //= {};
90                $data->{$key}->{$subkey} = $data->{$combined_key};
91            }
92        }
93
94        # wrap Scalars and HashRefs in an ArrayRef as param() expects it (but leave ArrayRefs as is)
95        $cache{$_} = (ref $data->{$_} eq 'ARRAY' ? $data->{$_} : [ $data->{$_} ]) for keys %$data;
96
97        $self->logger->debug('JSON param: ' . Dumper $data) if $self->logger->is_debug;
98
99        $self->method('POST');
100    }
101
102    # special transformations: insert sanitized keys names in the cache so the
103    # check in param() will succeed.
104    foreach my $key (keys %cache) {
105        # Base64 encoded binary data
106        my $prefix_b64 = $self->_prefix_base64;
107        if (my ($item) = $key =~ /^$prefix_b64(.*)/) { $cache{$item} = undef; next }
108
109        # JWT encrypted data
110        my $prefix_jwt = $self->_prefix_jwt;
111        if (my ($item) = $key =~ /^$prefix_jwt(.*)/) { $cache{$item} = undef; next }
112    }
113
114    $self->cache( \%cache );
115
116}
117
118sub param {
119
120    my $self = shift;
121    my $key = shift;
122
123    confess 'param() must be called in scalar context' if wantarray; # die
124
125    my @values = $self->_param($key); # list context
126    return $values[0] if defined $values[0];
127    return;
128}
129
130sub multi_param {
131
132    my $self = shift;
133    my $key = shift;
134
135    confess 'multi_param() must be called in list context' unless wantarray; # die
136    my @values = $self->_param($key); # list context
137    return @values;
138}
139
140sub param_keys {
141
142    my $self = shift;
143
144    # send all keys
145    confess 'param_keys() must be called in list context' unless wantarray; # die
146    return keys %{$self->cache};
147}
148
149sub _param {
150
151    my $self = shift;
152    my $key = shift;
153
154    confess "param() / multi_param() expect a single key (string) as argument\n" if (not $key or ref $key); # die
155
156    my $msg = sprintf "Param request for '%s': ", $key;
157
158    # try key without trailing array indicator if it does not exist
159    if ($key =~ m{\[\]\z} && !exists $self->cache->{$key}) {
160        $key = substr($key,0,-2);
161        $msg.= "strip array markers, new key '$key', ";
162    }
163
164    # valid key?
165    return unless exists $self->cache->{$key};
166
167    # cache miss - query parameter
168    unless (defined $self->cache->{$key}) {
169        my $cgi = $self->cgi;
170
171        my $prefix_b64 = $self->_prefix_base64;
172        my $prefix_jwt = $self->_prefix_jwt;
173
174        my @queries = (
175            # Try CGI parameters (and strip whitespaces)
176            sub {
177                return unless $cgi;
178                return map { my $v = $_; $v =~ s/^\s+|\s+$//g; $v } ($cgi->multi_param($key))
179            },
180            # Try Base64 encoded parameter from JSON input
181            sub {
182                return map { decode_base64($_) } $self->_get_cache($prefix_b64.$key)
183            },
184            # Try Base64 encoded CGI parameters
185            sub {
186                return unless $cgi;
187                return map { decode_base64($_) } $cgi->multi_param($prefix_b64.$key)
188            },
189            # Try JWT encrypted JSON data (may be deep structure when decrypted)
190            sub {
191                return map { $self->_decrypt_jwt($_) } $self->_get_cache($prefix_jwt.$key)
192            },
193            # Try JWT encrypted CGI parameters (may be deep structure when decrypted)
194            sub {
195                return unless $cgi;
196                return map { $self->_decrypt_jwt($_) } $cgi->multi_param($prefix_jwt.$key)
197            },
198        );
199
200        for my $query (@queries) {
201            my @values = $query->();
202            if (scalar @values) {
203                $self->cache->{$key} = \@values;
204                last;
205            }
206        }
207        $self->logger->trace($msg . 'not in cache. Query result: (' . join(', ', $self->_get_cache($key)) . ')') if $self->logger->is_trace;
208    }
209    else {
210        $self->logger->trace($msg . 'return from cache');
211    }
212
213    return $self->_get_cache($key); # list
214}
215
216# Returns a list of values (may be a single value or an empty list)
217sub _get_cache {
218
219    my $self = shift;
220    my $key = shift;
221
222    return @{ $self->cache->{$key} // [] }
223
224}
225
226sub _decrypt_jwt {
227
228    my $self = shift;
229    my $token = shift;
230
231    return unless $token;
232
233    my $jwt_key = $self->session->param('jwt_encryption_key');
234    unless ($jwt_key) {
235        $self->logger->debug("JWT encrypted parameter received but client session contains no decryption key");
236        return;
237    }
238
239    my $decrypted = decode_jwt(token => $token, key => $jwt_key);
240    unless (ref $decrypted eq 'HASH') {
241        $self->logger->error("Decrypted JWT data is not a HashRef but a " . ref $decrypted);
242        return;
243    }
244
245    $decrypted->{__jwt_key} = $jwt_key; # prove that it originated from JWT encoded data
246
247    return $decrypted;
248
249}
250
251__PACKAGE__->meta->make_immutable;
252
253
254__END__;
255
256=head1 Name
257
258OpenXPKI::Client::UI::Request
259
260=head1 Description
261
262This class is used to hold the input data received as from the webserver
263and provides a transparent interface to the application to retrieve
264parameter values regardless which transport format was used.
265
266If the data was POSTed as JSON blob, the parameters are already expanded
267with the values in the I<cache> hash. If data was send via a CGI method
268(either form-encoded or GET), the I<cache> hash holds the keys and the
269value undef and the parameter expansion is done on the first request to
270L</param>.
271
272=head1 Methods
273
274=head2 param
275
276Retrieves the value(s) of the named parameter.
277
278The L</param> method will B<not> try to guess the type of the attribute,
279the requestor must use L</multi_param> or call C<param> in list context to
280retrieve a multi-valued attribute.
281
282As the CGI transport does not provide information on the character of the
283attribute, the class always tries to translate items from scalar to list
284and vice-versa.
285
286=head2 multi_param
287
288Retrieves the named parameter but enforces list context.
289