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