ADDED demos/README.txt Index: demos/README.txt ================================================================== --- /dev/null +++ demos/README.txt @@ -0,0 +1,30 @@ +This directory contain example files for how to use the TLS package to perform +common functions. These are just a few of the possibilities. + +gets_blocking_no_variable.tcl +Download a webpage using gets, no variable arg, and blocking I/O. + +gets_blocking_with_variable.tcl +Download a webpage using gets, variable arg, and blocking I/O. + +gets_nonblocking_no_variable.tcl +Download a webpage using gets, no variable arg, and non-blocking I/O. + +gets_nonblocking_with_variable.tcl +Download a webpage using gets, variable arg, and non-blocking I/O. + +http_get_file.tcl +Download a webpage using the http package. + +http_get_webpage.tcl +Download a file using the http package. + +http_get_webpage_proxy.tcl +Download a file using the http and autoproxy packages. + +read_blocking_webpage.tcl +Download a webpage using read and blocking I/O. + +read_nonblocking_webpage.tcl +Download a webpage using read and non-blocking I/O. + ADDED demos/gets_blocking_no_variable.tcl Index: demos/gets_blocking_no_variable.tcl ================================================================== --- /dev/null +++ demos/gets_blocking_no_variable.tcl @@ -0,0 +1,67 @@ +################################################# +# +# Example 1: Blocking channel gets with no variable +# +################################################# + +package require Tcl 8.6- +package require tls + +set host "www.google.com" +set port 443 +set path "/" +set protocol "http/1.1" + +# +# Send HTTP Get Request +# +proc http_get {ch host path protocol} { + puts $ch [format "GET %s %s" $path [string toupper $protocol]] + puts $ch [format "User-Agent: Mozilla/4.0 (compatible; %s)" $::tcl_platform(os)] + puts $ch [format "Host: %s" $host] + puts $ch [format "Connection: close"] + puts $ch "" + flush $ch +} + +# Save returned data to file +proc save_file {filename data} { + if {[catch {open $filename wb} ch]} { + return -code error $ch + } + fconfigure $ch -buffersize 16384 -encoding utf-8 -translation crlf + puts $ch $data + close $ch +} + + + +proc gets_blocking_no_variable {host port path protocol} { + set result "" + + # Open socket + set ch [::tls::socket -servername $host -request 1 -require 1 -alpn [list [string tolower $protocol]] $host $port] + chan configure $ch -blocking 1 -buffering line -buffersize 16384 -encoding utf-8 -translation {auto crlf} + + # Initiate handshake + ::tls::handshake $ch + after 1000 + + # Send get request + http_get $ch $host $path $protocol + after 1000 + + # Get data + while {1} { + set line [gets $ch] + if {!([string length $line] == 0 && [eof $ch])} { + append result $line "\n" + } elseif {[eof $ch]} { + close $ch + break + } + } + return $result +} + +save_file "gets_blocking_no_variable.txt" [gets_blocking_no_variable $host $port $path $protocol] ADDED demos/gets_blocking_with_variable.tcl Index: demos/gets_blocking_with_variable.tcl ================================================================== --- /dev/null +++ demos/gets_blocking_with_variable.tcl @@ -0,0 +1,66 @@ +################################################# +# +# Example 2: Blocking channel gets with variable +# +################################################# + +package require Tcl 8.6- +package require tls + +set host "www.google.com" +set port 443 +set path "/" +set protocol "http/1.1" + +# +# Send HTTP Get Request +# +proc http_get {ch host path protocol} { + puts $ch [format "GET %s %s" $path [string toupper $protocol]] + puts $ch [format "User-Agent: Mozilla/4.0 (compatible; %s)" $::tcl_platform(os)] + puts $ch [format "Host: %s" $host] + puts $ch [format "Connection: close"] + puts $ch "" + flush $ch +} + +# Save returned data to file +proc save_file {filename data} { + if {[catch {open $filename wb} ch]} { + return -code error $ch + } + fconfigure $ch -buffersize 16384 -encoding utf-8 -translation crlf + puts $ch $data + close $ch +} + + + +proc gets_blocking_with_variable {host port path protocol} { + set result "" + + # Open socket + set ch [::tls::socket -servername $host -request 1 -require 1 -alpn [list [string tolower $protocol]] $host $port] + chan configure $ch -blocking 1 -buffering line -buffersize 16384 -encoding utf-8 -translation {auto crlf} + + # Initiate handshake + ::tls::handshake $ch + after 1000 + + # Send get request + http_get $ch $host $path $protocol + after 1000 + + # Get data + while {1} { + if {[gets $ch line] > -1} { + append result $line "\n" + } elseif {[eof $ch]} { + close $ch + break + } + } + return $result +} + +save_file "gets_blocking_with_variable.txt" [gets_blocking_with_variable $host $port $path $protocol] ADDED demos/gets_nonblocking_no_variable.tcl Index: demos/gets_nonblocking_no_variable.tcl ================================================================== --- /dev/null +++ demos/gets_nonblocking_no_variable.tcl @@ -0,0 +1,77 @@ +################################################# +# +# Example 3: Non-blocking channel gets with no variable +# +################################################# + +package require Tcl 8.6- +package require tls + +set host "www.google.com" +set port 443 +set path "/" +set protocol "http/1.1" + +# +# Send HTTP Get Request +# +proc http_get {ch host path protocol} { + puts $ch [format "GET %s %s" $path [string toupper $protocol]] + puts $ch [format "User-Agent: Mozilla/4.0 (compatible; %s)" $::tcl_platform(os)] + puts $ch [format "Host: %s" $host] + puts $ch [format "Connection: close"] + puts $ch "" + flush $ch +} + +# Save returned data to file +proc save_file {filename data} { + if {[catch {open $filename wb} ch]} { + return -code error $ch + } + fconfigure $ch -buffersize 16384 -encoding utf-8 -translation crlf + puts $ch $data + close $ch +} + + + +proc handler {ch} { + set line [gets $ch] + if {[eof $ch]} { + # EOF + close $ch + set ::wait 1 + return + } elseif {![fblocked $ch]} { + # Full or empty line + append ::data $line "\n" + } else { + # Partial line + append ::data $line + } +} + +proc gets_non_blocking_no_variable {host port path protocol} { + set ::wait 0 + + # Open socket + set ch [::tls::socket -servername $host -request 1 -require 1 -alpn [list [string tolower $protocol]] $host $port] + chan configure $ch -blocking 0 -buffering line -buffersize 16384 -encoding utf-8 -translation {auto crlf} + fileevent $ch readable [list handler $ch] + + # Initiate handshake + ::tls::handshake $ch + after 1000 + + # Send get request + after 5000 [list set ::wait 1] + http_get $ch $host $path $protocol + + vwait ::wait + catch {close $ch} +} + +set data "" +gets_non_blocking_no_variable $host $port $path $protocol +save_file "gets_non_blocking_no_variable.txt" $data ADDED demos/gets_nonblocking_with_variable.tcl Index: demos/gets_nonblocking_with_variable.tcl ================================================================== --- /dev/null +++ demos/gets_nonblocking_with_variable.tcl @@ -0,0 +1,77 @@ +################################################# +# +# Example 4: Non-blocking channel gets with variable +# +################################################# + +package require Tcl 8.6- +package require tls + +set host "www.google.com" +set port 443 +set path "/" +set protocol "http/1.1" + +# +# Send HTTP Get Request +# +proc http_get {ch host path protocol} { + puts $ch [format "GET %s %s" $path [string toupper $protocol]] + puts $ch [format "User-Agent: Mozilla/4.0 (compatible; %s)" $::tcl_platform(os)] + puts $ch [format "Host: %s" $host] + puts $ch [format "Connection: close"] + puts $ch "" + flush $ch +} + +# Save returned data to file +proc save_file {filename data} { + if {[catch {open $filename wb} ch]} { + return -code error $ch + } + fconfigure $ch -buffersize 16384 -encoding utf-8 -translation crlf + puts $ch $data + close $ch +} + + + +proc handler {ch} { + if {[gets $ch line] < 0 && [eof $ch]} { + # EOF + close $ch + set ::wait 1 + return + } elseif {![fblocked $ch]} { + # Full or empty line + append ::data $line "\n" + } else { + # Partial line + append ::data $line + } +} + +proc gets_non_blocking_with_variable {host port path protocol} { + set ::wait 0 + + # Open socket + set ch [::tls::socket -servername $host -request 1 -require 1 -alpn [list [string tolower $protocol]] $host $port] + chan configure $ch -blocking 0 -buffering line -buffersize 16384 -encoding utf-8 -translation {auto crlf} + fileevent $ch readable [list handler $ch] + + # Initiate handshake + ::tls::handshake $ch + after 1000 + + # Send get request + after 5000 [list set ::wait 1] + http_get $ch $host $path $protocol + + vwait ::wait + catch {close $ch} +} + +set data "" +gets_non_blocking_with_variable $host $port $path $protocol +save_file "gets_non_blocking_with_variable.txt" $data + ADDED demos/http_get_file.tcl Index: demos/http_get_file.tcl ================================================================== --- /dev/null +++ demos/http_get_file.tcl @@ -0,0 +1,30 @@ +################################################# +# +# Download file using HTTP package +# +################################################# + +package require Tcl 8.6- +package require tls +package require http + +set url "https://wiki.tcl-lang.org/sitemap.xml" +set protocol "http/1.1" +set filename [file tail $url] + +# Register https protocol handler with http package +http::register https 443 [list ::tls::socket -autoservername 1 -require 1 -alpn [list [string tolower $protocol]]] + +# Open output file +set ch [open $filename wb] + +# Get webpage +set token [::http::geturl $url -blocksize 16384 -channel $ch] +if {[http::status $token] ne "ok"} { + puts [format "Error %s" [http::status $token]] +} + +# Cleanup +::http::cleanup $token +close $ch + ADDED demos/http_get_webpage.tcl Index: demos/http_get_webpage.tcl ================================================================== --- /dev/null +++ demos/http_get_webpage.tcl @@ -0,0 +1,36 @@ +################################################# +# +# Download webpage using HTTP package +# +################################################# + +package require Tcl 8.6- +package require tls +package require http + +set url "https://www.tcl.tk/" +set port 443 +set protocol "http/1.1" + +# Register https protocol handler with http package +http::register https 443 [list ::tls::socket -autoservername 1 -require 1 -alpn [list [string tolower $protocol]]] + +# Get webpage +set token [::http::geturl $url -blocksize 16384] +if {[http::status $token] ne "ok"} { + puts [format "Error: \"%s\"" [http::status $token]] + ::http::cleanup $token + exit +} + +# Get web page +set data [http::data $token] + +# Cleanup +::http::cleanup $token + +# Save data to file +set ch [open "tcl_tk_home.html" wb] +puts $ch $data +close $ch + ADDED demos/http_get_webpage_proxy.tcl Index: demos/http_get_webpage_proxy.tcl ================================================================== --- /dev/null +++ demos/http_get_webpage_proxy.tcl @@ -0,0 +1,53 @@ +################################################# +# +# Download webpage using HTTP and proxy packages. +# +# Process: +# - Connect to the proxy +# - Send HTTP "CONNECT $targeturl HTTP/1.1". +# - Proxy responds with HTTP protocol response. +# - Do tls::import +# - Start handdshaking +# +################################################# + +package require Tcl 8.6- +package require tls +package require http +package require autoproxy +autoproxy::init + +set url "https://www.tcl.tk/" +set port 443 +set protocol "http/1.1" + +# Set these if not set by OS/Platform +if 0 { + autoproxy::configure -basic -proxy_host example.com -proxy_port 880 -username user -password password +} + + +# Register https protocol handler and proxy with http package +::http::register https 443 [list ::autoproxy::tls_socket -autoservername 1 -require 1 \ + -alpn [list [string tolower $protocol]]] + +# Get webpage +set token [::http::geturl $url -blocksize 16384] +if {[http::status $token] ne "ok"} { + puts [format "Error: \"%s\"" [http::status $token]] + ::http::cleanup $token + exit +} + +# Get web page +set data [http::data $token] + +# Cleanup +::http::cleanup $token + + +# Open output file +set ch [open "tcl_tk_home.html" wb] +puts $ch $data +close $ch + ADDED demos/read_blocking_webpage.tcl Index: demos/read_blocking_webpage.tcl ================================================================== --- /dev/null +++ demos/read_blocking_webpage.tcl @@ -0,0 +1,66 @@ +################################################# +# +# Read using blocking channel +# +################################################# + +package require Tcl 8.6- +package require tls + +set host "www.google.com" +set port 443 +set path "/" +set protocol "http/1.1" + +# +# Send HTTP Get Request +# +proc http_get {ch host path protocol} { + puts $ch [format "GET %s %s" $path [string toupper $protocol]] + puts $ch [format "User-Agent: Mozilla/4.0 (compatible; %s)" $::tcl_platform(os)] + puts $ch [format "Host: %s" $host] + puts $ch [format "Connection: close"] + puts $ch "" + flush $ch +} + +# Save returned data to file +proc save_file {filename data} { + if {[catch {open $filename wb} ch]} { + return -code error $ch + } + fconfigure $ch -buffersize 16384 -encoding utf-8 -translation crlf + puts $ch $data + close $ch +} + + + +proc read_blocking {host port path protocol} { + set result "" + + # Open socket + set ch [::tls::socket -servername $host -request 1 -require 1 -alpn [list [string tolower $protocol]] $host $port] + chan configure $ch -blocking 1 -buffering line -buffersize 16384 -encoding utf-8 -translation {auto crlf} + + # Initiate handshake + ::tls::handshake $ch + after 1000 + + # Send get request + http_get $ch $host $path $protocol + after 1000 + + # Get data + while {1} { + append result [read $ch 4096] + if {[eof $ch]} { + close $ch + break + } + } + return $result +} + +save_file "read_blocking_webpage.txt" [read_blocking $host $port $path $protocol] + ADDED demos/read_nonblocking_webpage.tcl Index: demos/read_nonblocking_webpage.tcl ================================================================== --- /dev/null +++ demos/read_nonblocking_webpage.tcl @@ -0,0 +1,70 @@ +################################################# +# +# Read using blocking channel +# +################################################# + +package require Tcl 8.6- +package require tls + +set host "www.google.com" +set port 443 +set path "/" +set protocol "http/1.1" + +# +# Send HTTP Get Request +# +proc http_get {ch host path protocol} { + puts $ch [format "GET %s %s" $path [string toupper $protocol]] + puts $ch [format "User-Agent: Mozilla/4.0 (compatible; %s)" $::tcl_platform(os)] + puts $ch [format "Host: %s" $host] + puts $ch [format "Connection: close"] + puts $ch "" + flush $ch +} + +# Save returned data to file +proc save_file {filename data} { + if {[catch {open $filename wb} ch]} { + return -code error $ch + } + fconfigure $ch -buffersize 16384 -encoding utf-8 -translation crlf + puts $ch $data + close $ch +} + + + +proc handler {ch} { + append ::data [read $ch 4096] + if {[eof $ch]} { + close $ch + set ::wait 1 + } +} + +proc read_nonblocking {host port path protocol} { + set result "" + + # Open socket + set ch [::tls::socket -servername $host -request 1 -require 1 -alpn [list [string tolower $protocol]] $host $port] + chan configure $ch -blocking 1 -buffering line -buffersize 16384 -encoding utf-8 -translation {auto crlf} + fileevent $ch readable [list handler $ch] + + # Initiate handshake + ::tls::handshake $ch + after 1000 + + # Send get request + after 5000 [list set ::wait 1] + http_get $ch $host $path $protocol + + vwait ::wait + catch {close $ch} +} + +set data "" +read_nonblocking $host $port $path $protocol +save_file "read_nonblocking_webpage.txt" $data + Index: doc/tls.html ================================================================== --- doc/tls.html +++ doc/tls.html @@ -770,11 +770,12 @@ It may be removed from future releases.

Debug Examples

These examples use the default Unix platform SSL certificates. For standard installations, -cadir and -cafile should not be needed. If your certificates -are in non-standard locations, specify -cadir or -cafile as needed.

+are in non-standard locations, specify -cadir or -cafile as needed. See the +demos directory for more elaborate examples.

Example #1: Use HTTP package

 package require http
 package require tls
 set url "https://www.tcl.tk/"

Index: doc/tls.man
==================================================================
--- doc/tls.man
+++ doc/tls.man
@@ -862,11 +862,12 @@
 
 [section "Debug Examples"]
 
 These examples use the default Unix platform SSL certificates. For standard
 installations, -cadir and -cafile should not be needed. If your certificates
-are in non-standard locations, specify -cadir or -cafile as needed.
+are in non-standard locations, specify -cadir or -cafile as needed. See the
+demos directory for more elaborate examples.
 
 [para]
 
 Example #1: Use HTTP package
 

Index: doc/tls.n
==================================================================
--- doc/tls.n
+++ doc/tls.n
@@ -1055,11 +1055,12 @@
 \fIThe use of the variable \fBtls::debug\fR is not recommended\&.
 It may be removed from future releases\&.\fR
 .SH "DEBUG EXAMPLES"
 These examples use the default Unix platform SSL certificates\&. For standard
 installations, -cadir and -cafile should not be needed\&. If your certificates
-are in non-standard locations, specify -cadir or -cafile as needed\&.
+are in non-standard locations, specify -cadir or -cafile as needed\&. See the
+demos directory for more elaborate examples\&.
 .PP
 Example #1: Use HTTP package
 .CS
 
 

Index: win/makefile.vc
==================================================================
--- win/makefile.vc
+++ win/makefile.vc
@@ -138,11 +138,11 @@
 
 # The default install target only installs binaries and scripts so add
 # an additional target for our documentation. Note this *adds* a target
 # since no commands are listed after it. The original targets for
 # install (from targets.vc) will remain.
-install: pkgindex default-install default-install-docs-html
+install: pkgindex default-install default-install-docs-html default-install-demos
 !IF EXIST($(SSL_INSTALL_FOLDER)\bin\libcrypto-*-x64.dll)
 	@xcopy /c /y "$(SSL_INSTALL_FOLDER)\bin\libcrypto-*-x64.dll" "$(PRJ_INSTALL_DIR)"
 !ENDIF
 !IF EXIST($(SSL_INSTALL_FOLDER)\bin\libssl-*-x64.dll)
 	@xcopy /c /y "$(SSL_INSTALL_FOLDER)\bin\libssl-*-x64.dll" "$(PRJ_INSTALL_DIR)"