1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
| ###############################################################################
#
# common.tcl --
#
# Extensible Adaptable Generalized Logic Engine (Eagle)
# Eagle Common Tools Package
#
# Copyright (c) 2007-2012 by Joe Mistachkin. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: $
#
###############################################################################
#
# NOTE: This script file uses features that are only present in Tcl 8.4 or
# higher (e.g. the "eq" operator for [expr], etc).
#
if {![package vsatisfies [package provide Tcl] 8.4]} then {
error "need Tcl 8.4 or higher"
}
#
# NOTE: This script file uses features that are not available or not needed
# in Eagle (e.g. the "http" and "tls" packages, etc).
#
if {[catch {package present Eagle}] == 0} then {
error "need native Tcl"
}
###############################################################################
namespace eval ::Eagle::Tools::Common {
#
# NOTE: *HACK* Skip defining this procedure if it is already defined in the
# global namespace.
#
if {[llength [info commands ::appendArgs]] == 0} then {
#
# NOTE: This procedure was stolen from the "auxiliary.eagle" script.
# This procedure accepts an any number of arguments. The arguments
# are appended into one big string, verbatim. The resulting string
# is returned. Normally, this procedure is used to avoid undesired
# string interpolation operations.
#
# <ignore>
proc appendArgs { args } {
eval append result $args
}
}
#
# NOTE: *HACK* Skip defining this procedure if it is already defined in the
# global namespace.
#
if {[llength [info commands ::makeBinaryChannel]] == 0} then {
#
# NOTE: This procedure was stolen from the "file1.eagle" script. This
# procedure reconfigures the specified channel to full binary mode.
#
# <ignore>
proc makeBinaryChannel { channel } {
fconfigure $channel -encoding binary -translation binary; # BINARY DATA
}
}
#
# NOTE: *HACK* Skip defining this procedure if it is already defined in the
# global namespace.
#
if {[llength [info commands ::writeFile]] == 0} then {
#
# NOTE: This procedure was stolen from the "file1.eagle" script. This
# procedure writes all data to the specified binary file and returns
# an empty string. Previous data contained in the file, if any, is
# lost.
#
# <ignore>
proc writeFile { fileName data } {
set channel [open $fileName {WRONLY CREAT TRUNC}]
makeBinaryChannel $channel
puts -nonewline $channel $data
close $channel
return ""
}
}
#
# NOTE: This procedure was stolen from the "common.tcl" script. This
# procedure sets up the default values for all HTTP configuration
# parameters used by this package. If the force argument is
# non-zero, any existing values will be overwritten and set back
# to their default values.
#
proc setupCommonVariables { force } {
#
# NOTE: Should the HTTP request processor attempt to force the use of
# HTTPS for URIs that were originally HTTP? This setting is only
# applicable to native Tcl.
#
variable forceSecureUri; # DEFAULT: true
if {$force || ![info exists forceSecureUri]} then {
set forceSecureUri true
}
#
# NOTE: Should the HTTP request processor fail if the "tls" package is
# not available?
#
variable mustHaveTls; # DEFAULT: true
if {$force || ![info exists mustHaveTls]} then {
set mustHaveTls true
}
#
# NOTE: Is this HTTP request processor allowed to use plain HTTP if/when
# the "tls" package is not available? This should only be changed
# if the "tls" package cannot be easily installed for use with the
# native Tcl interpreter in use. It should be noted here that the
# official package repository server reserves the right to refuse
# plain HTTP connections, which means that changing this setting
# may be totally pointless.
#
variable allowInsecureUri; # DEFAULT: false
if {$force || ![info exists allowInsecureUri]} then {
set allowInsecureUri false
}
#
# NOTE: Emit diagnostic messages when the [::http::geturl] procedure is
# about to be called?
#
variable verboseGetUrl; # DEFAULT: false
if {$force || ![info exists verboseGetUrl]} then {
set verboseGetUrl false
}
#
# NOTE: Is this HTTP request processor allowed to use plain HTTP if/when
# the server responds with an HTTP redirect location to an original
# URI that was HTTPS? Otherwise, a script error will result.
#
variable allowInsecureRedirect; # DEFAULT: false
if {![info exists allowInsecureRedirect]} then {
set allowInsecureRedirect false
}
#
# NOTE: How long should we wait for the HTTP request to complete? This
# value is the number of milliseconds.
#
variable timeoutGetUrl; # DEFAULT: 0
if {![info exists timeoutGetUrl]} then {
set timeoutGetUrl 0
}
}
#
# NOTE: This procedure was stolen from the "common.tcl" script. It is
# designed to emit a message to the console. The channel argument
# is the channel where the message should be written. The string
# argument is the content of the message to emit. If the channel
# argument is an empty string, nothing is written.
#
proc pageOut { channel string } {
if {[string length $channel] > 0} then {
catch {
puts -nonewline $channel $string; flush $channel
}
}
}
#
# NOTE: This procedure was stolen from the "common.tcl" script. It is
# designed to emit a message to the HTTP client log. The string
# argument is the content of the message to emit. If the string
# argument is an empty string, nothing is written.
#
proc pageLog { string } {
if {[string length $string] > 0} then {
catch {
tclLog [appendArgs \
[pid] " : " [clock seconds] " : http : " $string]
}
}
}
#
# NOTE: This procedure was stolen from the "common.tcl" script. It is
# designed to setup the pending progress indicator callback and
# save its working state.
#
proc setupPageProgress { channel type milliseconds } {
#
# NOTE: This variable is used to keep track of the currently scheduled
# (i.e. pending) [after] event.
#
variable afterForPageProgress
#
# NOTE: Scheduled the necessary [after] event, using the [pageProgress]
# procedure, which is defined further down in this file.
#
set afterForPageProgress [after $milliseconds [namespace code \
[list pageProgress $channel $type $milliseconds]]]
}
#
# NOTE: This procedure was stolen from the "common.tcl" script. It is
# designed to cancel the pending progress indicator callback and
# cleanup its working state.
#
proc cancelPageProgress {} {
#
# NOTE: This variable is used to keep track of the currently scheduled
# (i.e. pending) [after] event.
#
variable afterForPageProgress
#
# NOTE: If there is a currently scheduled [after] event, cancel it.
#
if {[info exists afterForPageProgress]} then {
catch {after cancel $afterForPageProgress}
unset -nocomplain afterForPageProgress
}
}
#
# NOTE: This procedure was stolen from the "common.tcl" script. It is
# designed to emit a progress indicator while an HTTP request is
# being processed. The channel argument is the Tcl channel where
# the progress indicator should be emitted. The type argument is
# the single-character progress indicator. The milliseconds
# argument is the number of milliseconds to wait until the next
# periodic progress indicator should be emitted. This procedure
# reschedules its own execution.
#
proc pageProgress { channel type milliseconds } {
#
# NOTE: Show that something is happening...
#
pageOut $channel $type
#
# NOTE: Make sure that we are scheduled to run again, if requested;
# also, before doing that, make sure there is not already an
# associated [after] event pending.
#
cancelPageProgress
if {$milliseconds > 0} then {
setupPageProgress $channel $type $milliseconds
}
}
#
# NOTE: This procedure was stolen from the "common.tcl" script. It is
# designed to process a single HTTP request, including any HTTP
# 3XX redirects (up to the specified limit), and return the raw
# HTTP response data. It may raise any number of script errors.
#
# <public>
proc getFileViaHttp { uri redirectLimit channel quiet args } {
#
# NOTE: This global variable is used to check the running version of
# Tcl.
#
global tcl_version
#
# NOTE: This variable is used to determine if plain HTTP URIs should be
# converted to HTTPS, if the "tls" package is available.
#
variable forceSecureUri
#
# NOTE: This variable is used to determine if an error should be raised
# if the "tls" package is not available.
#
variable mustHaveTls
#
# NOTE: This variable is used to determine if plain HTTP is allowed if
# the "tls" package is not available.
#
variable allowInsecureUri
#
# NOTE: This variable is used to determine if a diagnostic message is
# emitted when [::http::geturl] is about to be called.
#
variable verboseGetUrl
#
# NOTE: This variable is used to determine if plain HTTP is allowed if
# an HTTP redirect response contains an HTTP URI and the original
# URI was HTTPS.
#
variable allowInsecureRedirect
#
# NOTE: This variable is used to determine the timeout milliseconds for
# HTTP requests.
#
variable timeoutGetUrl
#
# NOTE: This procedure requires the modern version of the HTTP package,
# which is typically included with the Tcl core distribution.
#
package require http 2.0
#
# NOTE: Tcl 8.6 added support for IPv6; however, on some machines this
# support can cause sockets to hang for a long time. Therefore,
# for now, by default, always force the use of IPv4.
#
if {![info exists ::no(tclSocketAfInet)] && \
[info exists tcl_version] && $tcl_version >= 8.6} then {
namespace eval ::tcl::unsupported {}
set ::tcl::unsupported::socketAF inet
}
#
# NOTE: Setup lowercase URI scheme prefixes used within this procedure
# to detect and/or change the URI scheme used. By default, this
# procedure will always attempt to force HTTPS use when the "tls"
# package is available -AND- it disallows redirects from HTTPS to
# HTTP -AND- it disallows using HTTP when the "tls" package is
# unavailable.
#
set http http://
set httpLen [string length $http]
set httpEnd [expr {$httpLen - 1}]
set https https://
set httpsLen [string length $https]
set httpsEnd [expr {$httpsLen - 1}]
#
# NOTE: If the "tls" package is available, always attempt to use HTTPS;
# otherwise, only attempt to use HTTP if explicitly allowed.
#
if {[catch {package require tls} error] == 0} then {
::http::register https 443 [list ::tls::socket -tls1 true]
if {$forceSecureUri} then {
if {[string tolower [string range $uri 0 $httpEnd]] eq $http} then {
set uri [appendArgs $https [string range $uri $httpLen end]]
}
}
} else {
if {$mustHaveTls} then {
error [appendArgs \
"the \"tls\" package cannot be loaded: " $error]
}
if {$allowInsecureUri} then {
if {[string tolower [string range $uri 0 $httpsEnd]] eq $https} then {
set uri [appendArgs $http [string range $uri $httpsLen end]]
}
}
}
#
# NOTE: Unless the caller forbids it, display progress messages during
# the download.
#
if {!$quiet} then {
pageProgress $channel . 250
}
#
# NOTE: All downloads are handled synchronously, which is not ideal;
# however, it is simple. Keep going as long as there are less
# than X redirects.
#
set redirectCount 0
while {1} {
#
# NOTE: Build the (optional?) list of options for the HTTP call.
#
set localArgs [list]
if {$timeoutGetUrl != 0} then {
lappend localArgs -timeout $timeoutGetUrl; # milliseconds
}
if {[llength $args] > 0} then {
eval lappend localArgs $args
}
#
# NOTE: Issue the HTTP request now, grabbing the resulting token.
#
if {$verboseGetUrl} then {
#
# NOTE: Emit important diagnostic information related to this
# HTTP request here. This may be enhanced in the future.
#
pageLog [appendArgs \
"attempting to download URL \"" $uri "\" with arguments \"" \
$localArgs \"...]
}
#
# NOTE: Attempt to perform the actual HTTP request. This can fail
# in an almost unlimited number of ways, which is fun.
#
set token [eval ::http::geturl [list $uri] $localArgs]
#
# NOTE: Grab the HTTP status. It must be "ok" in order to proceed.
#
set status [::http::status $token]
if {$status ne "ok"} then {
error [appendArgs \
"bad HTTP status \"" $status "\" is not \"ok\""]
}
#
# NOTE: Grab the HTTP response code and data now as they are needed
# in almost all cases.
#
set code [::http::ncode $token]; set data [::http::data $token]
#
# NOTE: If the HTTP response code is an empty string that may
# indicate a serious bug in the tls (or http) package for
# this platform. So far, this issue has only been seen
# with the tls 1.6.1 package that shipped with macOS.
#
if {[string length $code] == 0} then {
error [appendArgs \
"received empty HTTP response code for URL \"" $uri \
"\", the \"tls\" (and/or \"http\") package(s) may be " \
"broken for this Tcl installation (or platform)"]
}
#
# NOTE: Check the HTTP response code, in order to follow any HTTP
# redirect responses.
#
switch -glob -- $code {
100 -
101 -
102 {
::http::cleanup $token; error [appendArgs \
"unsupported informational HTTP response status code " \
$code ", data: " $data]
}
200 -
201 -
202 -
203 -
204 -
205 -
206 -
207 -
208 -
226 {
#
# NOTE: Ok, the HTTP response is actual data of some kind (which
# may be empty).
#
::http::cleanup $token; break
}
301 -
302 -
303 -
307 -
308 {
#
# NOTE: Unless the caller forbids it, display progress messages
# when an HTTP redirect is returned.
#
if {!$quiet} then {
pageProgress $channel > 0
}
#
# NOTE: We hit another HTTP redirect. Stop if there are more
# than X.
#
incr redirectCount
#
# TODO: Maybe make this limit more configurable? The caller
# can pass any negative integer to disable it entirely
# -OR- zero to completely disallow any redirects.
#
if {$redirectLimit >= 0 && \
$redirectCount > $redirectLimit} then {
#
# NOTE: Just "give up" and raise a script error.
#
::http::cleanup $token; error [appendArgs \
"redirection limit of " $redirectLimit " exceeded"]
}
#
# NOTE: Grab the metadata associated with this HTTP response.
#
unset -nocomplain meta; array set meta [::http::meta $token]
#
# NOTE: Is there actually a new URI (location) to use?
#
if {[info exist meta(Location)]} then {
#
# NOTE: Ok, grab it now. Later, at the top of the loop,
# it will be used in the subsequent HTTP request.
#
set location $meta(Location); unset meta
#
# NOTE: For security, by default, do NOT follow an HTTP
# redirect if it attempts to redirect from HTTPS
# to HTTP.
#
if {!$allowInsecureRedirect && \
[string tolower [string range \
$uri 0 $httpsEnd]] eq $https && \
[string tolower [string range \
$location 0 $httpsEnd]] ne $https} then {
#
# NOTE: Just "give up" and raise a script error.
#
::http::cleanup $token; error [appendArgs \
"refused (insecure) redirect from \"" $uri \
"\" to \"" $location \
"\" with HTTP response status code " $code]
}
#
# NOTE: Replace the original URI with the new one, for
# use in the next HTTP request.
#
set uri $location
#
# NOTE: Cleanup the current HTTP token now beause a new
# one will be created for the next request.
#
::http::cleanup $token
} else {
#
# NOTE: Just "give up" and raise a script error.
#
::http::cleanup $token; error [appendArgs \
"redirect from \"" $uri \
"\" missing location, HTTP response status code " \
$code ", data: " $data]
}
}
300 -
304 -
305 -
306 {
::http::cleanup $token; error [appendArgs \
"unsupported redirection HTTP response status code " \
$code ", data: " $data]
}
4?? {
::http::cleanup $token; error [appendArgs \
"client error HTTP response status code " $code ", data: " \
$data]
}
5?? {
::http::cleanup $token; error [appendArgs \
"server error HTTP response status code " $code ", data: " \
$data]
}
default {
::http::cleanup $token; error [appendArgs \
"unrecognized HTTP response status code " $code ", data: " \
$data]
}
}
}
#
# NOTE: If there is a currently scheduled [after] event, cancel it.
# This is NOT done if the caller enabled quiet mode, because
# there should be none of our [after] events present in that
# case.
#
if {!$quiet} then {
cancelPageProgress
}
#
# NOTE: If progress messages were emitted, start a fresh line.
#
if {!$quiet} then {
pageOut $channel [appendArgs " " $uri \n]
}
return $data
}
#
# NOTE: First, setup the variables associated with this package.
#
setupCommonVariables false
#
# NOTE: Export the procedures from this namespace that are designed to be
# used by external scripts.
#
namespace export appendArgs getFileViaHttp pageOut writeFile
#
# NOTE: Provide the package to the interpreter.
#
package provide Eagle.Tools.Common 1.0
}
|