1# -- formbroker.tcl 2# 3# Form validation and sanitation tool. Kindly donated by 4# Karl Lehenbauer (Flightaware.com) 5# 6# Copyright 2017 The Rivet Team 7# 8# Licensed to the Apache Software Foundation (ASF) under one 9# or more contributor license agreements. See the NOTICE file 10# distributed with this work for additional information 11# regarding copyright ownership. The ASF licenses this file 12# to you under the Apache License, Version 2.0 (the 13# "License"); you may not use this file except in compliance 14# with the License. You may obtain a copy of the License at 15# 16# http://www.apache.org/licenses/LICENSE-2.0 17# 18# Unless required by applicable law or agreed to in writing, 19# software distributed under the License is distributed on an 20# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 21# KIND, either express or implied. See the License for the 22# specific language governing permissions and limitations 23# under the License. 24 25namespace eval FormBroker { 26 variable form_definitions [dict create] 27 variable form_list [dict create] 28 variable string_quote force_quote 29 variable form_count 0 30 # 31 # response_security_error - issue an error with errorCode 32 # 33 # set appropriate -- we expect the rivet error handler 34 # to catch this and do the right thing 35 # 36 37 proc response_security_error {type message} { 38 39 error $message "" [list RIVET SECURITY $type $message] 40 41 } 42 43 # 44 # force_response_integers - error if any of named vars in response doesn't exist 45 # 46 # or isn't an integer 47 # 48 49 proc force_response_integers {_response args} { 50 upvar $_response response 51 52 require_response_vars response {*}$args 53 54 foreach var $args { 55 56 if {![regexp {[0-9-]*} response($var)]} { 57 response_security_error NOT_INTEGER "illegal content in $var" 58 } 59 60 if {![scan $response($var) %d response($var)]} { 61 response_security_error NOT_INTEGER "illegal content in $var" 62 } 63 } 64 65 } 66 67 68 # 69 # force_response_integer_in_range - error if var in response isn't an integer 70 # or if it isn't in range 71 # 72 73 proc force_response_integer_in_range {_response var lowest highest} { 74 upvar $_response response 75 76 force_response_integers response $var 77 78 if {$response($var) < $lowest || $response($var) > $highest} { 79 response_security_error "OUT_OF_RANGE" "$var out of range" 80 } 81 82 } 83 84 # -- force_quote 85 # 86 87 proc force_quote {str} { 88 return "'$str'" 89 } 90 91 92 # -- force_sanitize_response_strings 93 94 proc force_sanitize_response_strings {_response args} { } 95 96 97 # 98 # force_quote_response_strings - sanitize and pg_quote all the specified strings in the array 99 # 100 101 proc force_quote_response_strings {_response args} { 102 upvar $_response response 103 104 force_sanitize_response_strings response {*}$args 105 106 foreach var $args { 107 set response($var) [$string_quote $response($var)] 108 } 109 110 } 111 112 113 114 # 115 # -- force_quote_response_unfilteredstrings - rewrite named response 116 # elements pg_quoted 117 # 118 119 proc force_quote_response_unfilteredstrings {_response args} { 120 upvar $_response response 121 122 require_response_vars response {*}$args 123 124 foreach var $args { 125 set response($var) [$string_quote $response($var)] 126 } 127 128 } 129 130 # -- base validators 131 132 proc validate_string {_var_d} { 133 upvar $_var_d var_d 134 135 set valid FB_OK 136 dict with var_d { 137 if {$bounds > 0} { 138 if {($nonempty == 1) && ($var == "")} { 139 set valid FB_EMPTY_STRING 140 } elseif {$constrain} { 141 set var [string range $var 0 $bounds-1] 142 } elseif {[string length $var] > $bounds} { 143 set valid FB_STRING_TOO_LONG 144 } 145 } 146 } 147 return $valid 148 } 149 150 # -- validate_integer 151 # 152 # integer validation checks whether 153 # 154 # 1- the representation *is* an integer 155 # 2- if buonds exist the value must be between [-bound,bound] 156 # 3- if the bounds is a list of 2 elements the value must 157 # be between them 158 # 159 # If needed the variable is constrained within the bounds. 160 # 161 162 proc validate_integer {_var_d} { 163 upvar $_var_d var_d 164 #puts "var_d: $var_d" 165 166 set valid FB_OK 167 dict with var_d { 168 if {![string is integer $var]} { 169 return NOT_INTEGER 170 } 171 172 if {[llength $bounds] == 2} { 173 ::lassign $bounds min_v max_v 174 175 if {$constrain} { 176 set var [expr min($var,$max_v)] 177 set var [expr max($var,$min_v)] 178 set valid FB_OK 179 } elseif {($var > $max_v) || ($var < $min_v)} { 180 set valid FB_OUT_OF_BOUNDS 181 } else { 182 set valid FB_OK 183 } 184 185 } elseif {([llength $bounds] == 1) && ($bounds > 0)} { 186 187 if {$constrain} { 188 set var [expr min($bounds,$var)] 189 set var [expr max(-$bounds,$var)] 190 set valid FB_OK 191 } elseif {(abs($var) > $bounds)} { 192 set valid FB_OUT_OF_BOUNDS 193 } else { 194 set valid FB_OK 195 } 196 197 } 198 } 199 return $valid 200 } 201 202 proc validate_unsigned {_var_d} { 203 upvar $_var_d var_d 204 205 dict with var_d { 206 if {![string is integer $var]} { 207 return NOT_INTEGER 208 } 209 if {[llength $bounds] == 2} { 210 ::lassign $bounds min_v max_v 211 if {$constrain} { 212 set var [expr min($var,$max_v)] 213 set var [expr max($var,$min_v)] 214 set valid FB_OK 215 } elseif {($var > $max_v) || ($var < $min_v)} { 216 set valid FB_OUT_OF_BOUNDS 217 } else { 218 set valid FB_OK 219 } 220 221 } elseif {([llength $bounds] == 1) && \ 222 ($bounds > 0)} { 223 224 if {$constrain} { 225 set var [expr max(0,$var)] 226 set var [expr min($bounds,$var)] 227 set valid FB_OK 228 } elseif {($var > $bounds) || ($var < 0)} { 229 set valid FB_OUT_OF_BOUNDS 230 } else { 231 set valid FB_OK 232 } 233 234 } else { 235 236 if {$constrain} { 237 set var [expr max(0,$var)] 238 set valid FB_OK 239 } elseif {$var < 0} { 240 set valid FB_OUT_OF_BOUNDS 241 } else { 242 set valid FB_OK 243 } 244 245 } 246 } 247 return $valid 248 } 249 250 proc validate_email {_var_d} { 251 upvar $_var_d var_d 252 253 dict with var_d { 254 if {[regexp -nocase {[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,}} $var]} { 255 return FB_OK 256 } else { 257 return FB_INVALID_EMAIL 258 } 259 } 260 } 261 262 proc validate_boolean {_var_d} { 263 upvar $_var_d var_d 264 265 dict with var_d { 266 if {[string is boolean $var]} { 267 if {$constrain} { 268 set var [string is true $var] 269 } 270 return FB_OK 271 } else { 272 return FB_INVALID_BOOLEAN 273 } 274 } 275 } 276 277 278 proc validate_variable_representation {_var_d} { 279 upvar $_var_d var_d 280 variable form_definitions 281 282 set validator [dict get $var_d validator] 283 if {[info commands $validator] == ""} { 284 set validator ::FormBroker::validate_string 285 } 286 set validation [$validator var_d] 287 288 dict set var_d field_validation $validation 289 290 return [string match $validation FB_OK] 291 } 292 293 294 proc validate_var {form_name var_name var_value {force_quoting "-noforcequote"}} { 295 variable form_definitions 296 upvar $var_value value 297 298 set force_quote_var [string match $force_quoting "-forcequote"] 299 300 set variable_d [dict get $form_definitions $form_name $var_name] 301 dict set variable_d var $value 302 set valid [validate_variable_representation variable_d] 303 304 set value [dict get $variable_d var] 305 if {[dict get $variable_d force_quote] || $force_quote_var} { 306 set value [$string_quote $value] 307 } 308 return $valid 309 } 310 311 # -- constrain_bounds 312 # 313 # During the form creation stage this method is called 314 # to correct possible inconsistencies with a field bounds 315 # definition 316 # 317 318 proc constrain_bounds {field_type _bounds} { 319 upvar $_bounds bounds 320 321 switch $field_type { 322 integer { 323 if {[llength $bounds] == 1} { 324 325 set bounds [list [expr -abs($bounds)] [expr abs($bounds)]] 326 327 } elseif {[llength $bounds] > 1} { 328 lassign $bounds l1 l2 329 330 set bounds [list [expr min($l1,$l2)] [expr max($l1,$l2)]] 331 } else { 332 set bounds 0 333 } 334 } 335 unsigned { 336 if {[llength $bounds] == 1} { 337 338 set bounds [list 0 [expr abs($bounds)]] 339 340 } elseif {[llength $bounds] > 1} { 341 342 lassign $bounds l1 l2 343 if {$l1 < 0} { set l1 0 } 344 if {$l2 < 0} { set l2 0 } 345 346 set bounds [list [expr min($l1,$l2)] [expr max($l1,$l2)]] 347 } else { 348 set bounds 0 349 } 350 } 351 } 352 } 353 354 # -- form_definition 355 # 356 # currently this call returns the dictionary 357 # of form field definitions. It's not meant to be 358 # used in regular development. It's supposed to be 359 # private to the FormBroker package 360 # and it may go away with future developments or 361 # change its interface and returned value 362 363 proc form_definition {form_name} { 364 variable form_definitions 365 366 return [dict get $form_definitions $form_name] 367 } 368 369 # -- validation_error 370 # 371 # returns the result of the last validation 372 # operation called on for this form. 373 # 374 375 376 proc validation_error {form_name} { 377 variable form_list 378 379 return [dict get $form_list $form_name form_validation] 380 } 381 382 383 # -- failing 384 # 385 # returns a list of variable-status pairs for each 386 # field in a form that did not validate 387 # 388 389 proc failing {form_name} { 390 set res {} 391 dict for {field field_d} [form_definition $form_name] { 392 dict with field_d { 393 if {$field_validation != "FB_OK"} { 394 lappend res $field $field_validation 395 } 396 } 397 } 398 return $res 399 } 400 401 # -- result 402 # 403 # accessor to the form field definitions. This procedure 404 # too is not (at least temporarily) to be called from 405 # outside the package 406 # 407 408 proc result {form_name form_field} { 409 variable form_definitions 410 411 return [dict get $form_definitions $form_name $form_field] 412 } 413 414 # --require_response_vars 415 # 416 # error if any of the specified are not in the response 417 # 418 419 proc require_response_vars {form_name _response} { 420 upvar $_response response 421 variable form_definitions 422 423 set missing_vars 0 424 dict for {var variable_d} [dict get $form_definitions $form_name] { 425 if {![info exists response($var)]} { 426 dict with form_definitions $form_name $var { 427 428 # if the variable was not in the response 429 # but a default was set then we copy this 430 # value in the variable descriptor and 431 # the response array as well 432 433 if {[info exists default]} { 434 set response($var) $default 435 set var $default 436 } else { 437 set field_validation MISSING_VAR 438 set missing_vars 1 439 } 440 441 } 442 } 443 } 444 445 if {$missing_vars} { 446 response_security_error MISSING_VAR \ 447 "var $var not present in $_response" 448 } 449 450 451 } 452 453 # -- validate 454 # 455 # 456 457 proc validate { form_name args } { 458 variable form_definitions 459 variable form_list 460 variable string_quote 461 462 set force_quote_vars 0 463 set arguments $args 464 if {[llength $arguments] == 0} { 465 error "missing required arguments" 466 } elseif {[llength $arguments] > 3} { 467 error "error calling validate, usage: validate ?-forcequote? response ?copy_response?" 468 } 469 470 while {[llength $arguments]} { 471 472 set arguments [::lassign $arguments a] 473 if {$a == "-forcequote"} { 474 set force_quote_vars 1 475 } elseif {![array exists response]} { 476 upvar $a response 477 } else { 478 upvar $a filtered_response 479 array set filtered_response {} 480 } 481 482 } 483 484 if {![array exists response]} { 485 error "error calling validate, usage: validate ?-forcequote? response ?copy_response?" 486 } 487 488 # we now go ahead validating the response variables 489 490 set form_valid true 491 492 set vars_to_validate [dict get $form_list $form_name vars] 493 if {[catch { 494 require_response_vars $form_name response 495 } er eopts]} { 496 497 #puts "$er $eopts" 498 dict set form_list $form_name form_validation FB_MISSING_VARS 499 return false 500 501 } 502 503 # field validation 504 505 dict with form_list $form_name { 506 set form_validation FB_OK 507 } 508 509 set form_d [dict get $form_definitions $form_name] 510 #puts "form_d: $form_d" 511 512 array unset response_a 513 dict for {var variable_d} $form_d { 514 515 dict set variable_d var $response($var) 516 if {[validate_variable_representation variable_d] == 0} { 517 518 dict set form_list $form_name form_validation FB_VALIDATION_ERROR 519 set form_valid false 520 521 } else { 522 523 # in case it was constrained we write the value back 524 # into the response array 525 526 if {[dict get $variable_d constrain]} { 527 set response_a($var) [dict get $variable_d var] 528 } else { 529 set response_a($var) $response($var) 530 } 531 532 if {[dict get $variable_d force_quote] || $force_quote_vars} { 533 534 set response_a($var) [$string_quote [dict get $variable_d var]] 535 536 } 537 } 538 dict set form_definitions $form_name $var $variable_d 539 #puts "validated $var -> $variable_d" 540 541 } 542 543 # if 'validate' has been called with a filtered_response array 544 # we clean it up and proceed copying the variable values into it 545 546 if {[array exists filtered_response]} { 547 array unset filtered_response 548 array set filtered_response [array get response_a] 549 } else { 550 array set response [array get response_a] 551 } 552 return $form_valid 553 } 554 555 # -- response 556 # 557 # 558 559 proc response {form_name {resp_a response}} { 560 upvar $resp_a response 561 variable form_definitions 562 563 dict for {var_name var_d} [dict get $form_definitions $form_name] { 564 catch {unset var} 565 catch {unset default} 566 567 dict with var_d { 568 569 if {[info exists var]} { 570 set response($var_name) $var 571 } elseif {[info exists default]} { 572 set response($var_name) $default 573 } 574 575 } 576 577 } 578 } 579 580 # -- reset 581 # 582 # 583 584 proc reset {form_name} { 585 variable form_definitions 586 variable form_list 587 588 dict set form_list $form_name form_validation FB_OK 589 dict for {var_name var_d} [dict get $form_definitions $form_name] { 590 catch {dict unset var_d $var_name var} 591 } 592 } 593 594 # -- destroy 595 # 596 # this method is designed to be called 597 # by an 'trace unset' event on the variable 598 # keeping the form description object. 599 # 600 601 proc destroy {form_name args} { 602 variable form_definitions 603 variable form_list 604 605 dict unset form_definitions $form_name 606 dict unset form_list $form_name 607 namespace delete ::FormBroker::${form_name} 608 #puts "destroy of $form_name finished" 609 } 610 611 # -- create 612 # 613 # creates a form object starting from a list of element descriptors 614 # 615 # the procedure accept a list of single descriptors, being each 616 # descriptor a sub-list itself 617 # 618 # - field_name 619 # - type (string, integer, unsigned, email, base64) 620 # - a list of the following keywords and related values 621 # 622 # - bounds <value> 623 # - bounds [low high] 624 # - check_routine [validation routine] 625 # - length [max length] 626 # 627 628 proc create {args} { 629 variable form_definitions 630 variable form_list 631 variable form_count 632 variable string_quote 633 634 set form_name "form${form_count}" 635 incr form_count 636 637 catch { namespace delete $form_name } 638 namespace eval $form_name { 639 640 foreach cmd { validate failing \ 641 form_definition \ 642 result validate_var \ 643 destroy validation_error \ 644 response reset } { 645 lappend cmdmap $cmd [list [namespace parent] $cmd [namespace tail [namespace current]]] 646 } 647 648 namespace ensemble create -map [dict create {*}$cmdmap] 649 unset cmdmap 650 unset cmd 651 652 } 653 654 dict set form_definitions $form_name [dict create] 655 dict set form_list $form_name [dict create vars {} \ 656 form_validation FB_OK \ 657 failing {} \ 658 default "" \ 659 quoting $string_quote] 660 661 while {[llength $args]} { 662 663 set args [::lassign $args e] 664 665 if {$e == "-quoting"} { 666 667 dict with form_list $form_name { 668 set args [::lassign $args quoting] 669 670 if {[uplevel [list info proc $quoting]] == ""} { 671 error [list RIVET INVALID_QUOTING_PROC \ 672 "Non existing quoting proc '$quoting'"] 673 } 674 set string_quote $quoting 675 } 676 continue 677 678 } 679 680 # each variable (field) definition must start with the 681 # variable name and variable type. Every other variable 682 # specification argument can be listed in arbitrary order 683 # with the only constraint that argument values must follow 684 # an argument name. If an argument is specified multiple times 685 # the last definition overrides the former ones 686 687 set e [::lassign $e field_name field_type] 688 689 # the 'vars' dictionary field stores the 690 # order of form fields in which they are processed 691 # (in general this order would be destroyed by the Tcl's hash 692 # tables) 693 694 dict with form_list $form_name {::lappend vars $field_name} 695 696 # this test would handle the case of the most simple possible 697 # variable definition (just the variable name) 698 699 if {$field_type == ""} { 700 set field_type string 701 } 702 703 dict set form_definitions $form_name $field_name \ 704 [list type $field_type \ 705 bounds 0 \ 706 constrain 0 \ 707 validator [namespace current]::validate_string \ 708 force_quote 0 \ 709 nonempty 0 \ 710 field_validation FB_OK] 711 712 dict with form_definitions $form_name $field_name { 713 714 switch $field_type { 715 integer { 716 set validator [namespace current]::validate_integer 717 } 718 unsigned { 719 set validator [namespace current]::validate_unsigned 720 } 721 email { 722 set validator [namespace current]::validate_email 723 } 724 boolean { 725 set validator [namespace current]::validate_boolean 726 } 727 string - 728 default { 729 set validator [namespace current]::validate_string 730 } 731 } 732 733 # 734 735 while {[llength $e] > 0} { 736 set e [::lassign $e field_spec] 737 738 switch $field_spec { 739 check_routine - 740 validator { 741 set e [::lassign $e validator] 742 } 743 length - 744 bounds { 745 set e [::lassign $e bounds] 746 constrain_bounds $field_type bounds 747 } 748 default { 749 set e [::lassign $e default] 750 751 # we must not assume the variable 'default' 752 # exists in the dictionary because we 753 # set it only in this code branch 754 755 dict set form_definitions $form_name $field_name default $default 756 } 757 nonempty { 758 759 # this flag forces the formbroker to 760 # signal empty strings as form data errors 761 762 set nonemtpy 1 763 } 764 constrain { 765 set constrain 1 766 } 767 noconstrain { 768 set constrain 0 769 } 770 quote { 771 set force_quote 1 772 } 773 } 774 } 775 776 # let's check for possible inconsitencies between 777 # data type and default value. For this purpose 778 # we create a copy of the variable dictionary 779 # representation then we call the validator on it 780 781 set variable_d [dict get $form_definitions $form_name $field_name] 782 dict set variable_d var $default 783 if {[$validator variable_d] != "FB_OK"} { 784 dict unset form_definitions $form_name $field_name default 785 } 786 } 787 } 788 return [namespace current]::$form_name 789 } 790 791 proc form_exists {form_cmd} { 792 variable form_definitions 793 794 return [dict exists $form_definitions [namespace tail $form_cmd]] 795 } 796 797 proc creategc {varname args} { 798 set formv [uplevel [list set $varname [::FormBroker::create {*}$args]]] 799 uplevel [list trace add variable $varname unset \ 800 [list [namespace current]::destroy [namespace tail $formv]]] 801 802 return $formv 803 } 804 805 namespace export * 806 namespace ensemble create 807} 808 809package provide formbroker 1.0.1 810