Posted to tcl by marc.ziegenhagen at Tue May 20 13:56:10 GMT 2014view raw

  1. package require http
  2. package require tls
  3.  
  4. ::tls::init -command tls_callback
  5.  
  6. ::http::register https 443 [list ::tls::socket \
  7. -require 1 -cadir "/etc/ssl/certs"]
  8.  
  9. proc bgerror {msg} {
  10. puts stderr "bgerror: $msg\n$::errorInfo"
  11. }
  12.  
  13. proc callback {token} {
  14. gloabl G
  15. upvar #0 $token state
  16.  
  17. puts "Callback: [arra yget $state]"
  18.  
  19. switch -- $state(status) {
  20. error {
  21. puts stderr "Error: $state(error)"
  22. }
  23. ok {
  24. puts "Body: $state(body)"
  25. }
  26. default {
  27. puts "Unknown state: $state(status)"
  28. }
  29. }
  30.  
  31. set G(run) 0
  32. http::destroy $token
  33. }
  34.  
  35. proc tls_callback {option args} {
  36.  
  37. #puts [concat $option $args]
  38.  
  39. switch -- $option {
  40. "error" {
  41. foreach {chan msg} $args break
  42.  
  43. puts "TLS/$chan: error: $msg"
  44. }
  45. "verify" {
  46. # poor man's lassign
  47. foreach {chan depth cert rc err} $args break
  48.  
  49. array set c $cert
  50.  
  51. if {$rc != "1"} {
  52. puts "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
  53. } else {
  54. puts "TLS/$chan: verify/$depth: $c(subject)"
  55. }
  56. return $rc
  57. }
  58. "info" {
  59. # poor man's lassign
  60. foreach {chan major minor state msg} $args break
  61.  
  62. if {$msg != ""} {
  63. append state ": $msg"
  64. }
  65. # For tracing
  66. upvar #0 tls::$chan cb
  67. set cb($major) $minor
  68.  
  69. #puts "TLS/$chan: $major/$minor: $state"
  70. }
  71. default {
  72. return -code error "bad option \"$option\":\
  73. must be one of error, info, or verify"
  74. }
  75. }
  76. }
  77.  
  78. set url "https://80.254.163.223/ippf/checkapplication"
  79. set timeout 15000
  80.  
  81. puts "URL: $url"
  82.  
  83. if {[catch {::http::geturl $url \
  84. -timeout $timeout -type multipart/form-data \
  85. -command [list callback]} token]} {
  86. puts stderr "Error: $token"
  87. exit 1
  88. }
  89. puts "url runs: $token"
  90.  
  91. set G(run) 1
  92. vwait G(run)
  93. puts "G(run): $G(run)"