Mercurial > projects > relmon

annotate relmon.tcl @ 1:cba4887feb2c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Check the content type of documents that are being downloaded Abort if the content type of the document being downloaded cannot be handled. This is to primarily to prevent accidental downloads of potentially large files.
author Guido Berhoerster <guido+relmon@berhoerster.name>
date Sun, 19 Oct 2014 20:56:27 +0200
parents 8c5330f6e9e4
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1 #!/usr/bin/tclsh
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
2 #
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
3 # Copyright (C) 2014 Guido Berhoerster <guido+relmon@berhoerster.name>
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
4 #
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
5 # Permission is hereby granted, free of charge, to any person obtaining
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
6 # a copy of this software and associated documentation files (the
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
7 # "Software"), to deal in the Software without restriction, including
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
8 # without limitation the rights to use, copy, modify, merge, publish,
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
9 # distribute, sublicense, and/or sell copies of the Software, and to
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
10 # permit persons to whom the Software is furnished to do so, subject to
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
11 # the following conditions:
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
12 #
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
13 # The above copyright notice and this permission notice shall be included
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
14 # in all copies or substantial portions of the Software.
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
15 #
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
16 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
17 # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
18 # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
19 # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
20 # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
21 # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
22 # SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
23
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
24 package require Tcl 8.5
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
25 package require http
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
26 package require tls
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
27 package require tdom
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
28 package require try
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
29 package require cmdline
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
30 package require control
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
31 package require html
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
32 package require htmlparse
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
33 package require json
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
34 package require json::write
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
35 package require logger
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
36 package require logger::utils
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
37 package require textutil::split
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
38 package require uri
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
39 package require uri::urn
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
40
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
41
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
42 namespace eval ::relmon {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
43 # version
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
44 variable VERSION 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
45 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
46
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
47
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
48 namespace eval ::relmon::common {
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
49 namespace export cmpVersions isUrlValid urlGetHost normalizeHttpHeaders \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
50 parseStateFile
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
51 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
52
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
53 # implementation of the Debian version comparison algorithm described at
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
54 # http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
55 proc ::relmon::common::cmpVersion {v1 v2} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
56 set v1Len [string length $v1]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
57 set v2Len [string length $v2]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
58 set v1Pos 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
59 set v2Pos 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
60 while {($v1Pos < $v1Len) || ($v2Pos < $v2Len)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
61 set firstNumDiff 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
62 # until reaching ASCII digits in both version strings compare character
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
63 # values which are modified as so they are sorted in the following
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
64 # order:
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
65 # - "~"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
66 # - missing character or ASCII digits
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
67 # - ASCII alphabet
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
68 # - everything else in the order of their unicode value
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
69 while {(($v1Pos < $v1Len) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
70 ![string match {[0123456789]} [string index $v1 $v1Pos]]) ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
71 (($v2Pos < $v2Len) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
72 ![string match {[0123456789]} [string index $v2 $v2Pos]])} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
73 foreach char [list [string index $v1 $v1Pos] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
74 [string index $v2 $v2Pos]] charValueName \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
75 {v1CharValue v2CharValue} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
76 if {$char eq "~"} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
77 set $charValueName -1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
78 } elseif {$char eq ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
79 set $charValueName 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
80 } elseif {[string match {[0123456789]} $char]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
81 set $charValueName 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
82 } elseif {[string match -nocase {[abcdefghijklmnopqrstuvwxyz]} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
83 $char]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
84 set $charValueName [scan $char "%c"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
85 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
86 set $charValueName [expr {[scan $char "%c"] + 0x7f + 1}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
87 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
88 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
89 if {$v1CharValue != $v2CharValue} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
90 return [expr {$v1CharValue - $v2CharValue}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
91 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
92 incr v1Pos
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
93 incr v2Pos
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
94 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
95
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
96 # strip leading zeros
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
97 while {[string index $v1 $v1Pos] eq "0"} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
98 incr v1Pos
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
99 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
100 while {[string index $v2 $v2Pos] eq "0"} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
101 incr v2Pos
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
102 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
103
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
104 # process digits until reaching a non-digit
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
105 while {[string match {[0123456789]} [string index $v1 $v1Pos]] &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
106 [string match {[0123456789]} [string index $v2 $v2Pos]]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
107 # record the first difference between the two numbers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
108 if {$firstNumDiff == 0} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
109 set firstNumDiff [expr {[string index $v1 $v1Pos] -
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
110 [string index $v2 $v2Pos]}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
111 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
112 incr v1Pos
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
113 incr v2Pos
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
114 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
115
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
116 # return if the number of one version has more digits than the other
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
117 # since the one with more digits is the larger number
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
118 if {[string match {[0123456789]} [string index $v1 $v1Pos]]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
119 return 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
120 } elseif {[string match {[0123456789]} [string index $v2 $v2Pos]]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
121 return -1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
122 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
123
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
124 # return the difference if the digits differed above
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
125 if {$firstNumDiff != 0} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
126 return $firstNumDiff
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
127 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
128 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
129
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
130 return 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
131 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
132
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
133 proc ::relmon::common::isUrlValid {url} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
134 return [expr {![catch {dict create {*}[uri::split $url]} urlParts] &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
135 ([dict get $urlParts "scheme"] in {"http" "https"}) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
136 ([dict get $urlParts "host"] ne "")}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
137 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
138
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
139 proc ::relmon::common::urlGetHost {url} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
140 return [expr {(![catch {dict create {*}[uri::split $url]} urlParts]) ?
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
141 [dict get $urlParts "host"] : ""}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
142 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
143
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
144 proc ::relmon::common::normalizeHttpHeaders {headers} {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
145 set httpHeaders [dict create]
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
146 foreach {header value} $headers {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
147 set words {}
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
148 foreach word [split $header "-"] {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
149 lappend words [string totitle $word]
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
150 }
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
151 dict set httpHeaders [join $words "-"] $value
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
152 }
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
153 return $httpHeaders
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
154 }
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
155
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
156 proc ::relmon::common::parseStateFile {stateFile} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
157 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
158 set f [open $stateFile "r"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
159 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
160 return -options $errorOptions \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
161 "failed to open state file \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
162 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
163 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
164 set state [json::json2dict [chan read $f]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
165 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
166 return -options $errorOptions \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
167 "failed to read from state file \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
168 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
169 # the json package does not set an error code
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
170 dict set errorOptions "-errorcode" {RELMON JSON_PARSE_ERROR}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
171 return -options $errorOptions \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
172 "failed to parse state file \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
173 } finally {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
174 close $f
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
175 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
176
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
177 return $state
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
178 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
179
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
180
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
181 namespace eval ::relmon::update {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
182 # commandline option help text
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
183 variable usage "usage: relmon update \[-dev\] \[-c max_connections\] \[-C\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
184 ca_dir\] \[-D delay\]\n\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
185 \ \[-H max_host_connections\] \[-i\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
186 item\[,...\]\] \[-l logfile\]\n\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
187 \ \[-r retries\] \[-t min_time\] watchlist\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
188 statefile"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
189
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
190 # configuration options
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
191 variable Config [dict create \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
192 "log_file" "" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
193 "log_level" "notice" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
194 "history_limit" 20 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
195 "connection_limit" 16 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
196 "host_connection_limit" 4 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
197 "transfer_time_limit" 60000 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
198 "retry_limit" 3 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
199 "host_delay" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
200 "timestamp_filter" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
201 "error_filter" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
202 "item_filter" {} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
203 "ca_dir" "" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
204 "state_file" "" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
205 "watchlist_file" ""]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
206
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
207 # exit status
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
208 variable ExitStatus
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
209
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
210 # transfer statistics
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
211 variable Statistics [dict create \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
212 "start_time" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
213 "end_time" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
214 "requests" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
215 "items" 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
216
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
217 # watchlist
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
218 variable Watchlist
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
219
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
220 # ID of a delayed run of ManageTransfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
221 variable ManageTransfersId ""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
222
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
223 # queue of pending transfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
224 variable Queue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
225
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
226 # number of active connections per host
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
227 variable HostConnections
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
228
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
229 # delays before opening a new connection to a host
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
230 variable HostDelays
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
231
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
232 # active transfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
233 variable ActiveTransfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
234
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
235 # buffer for tracking the state of unfinished items
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
236 variable StateBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
237
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
238 # buffer needed by htmlparse::parse for constructing the preprocessed HTML
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
239 # document
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
240 variable PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
241
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
242 # logger handle
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
243 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
244
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
245 # logfile handle
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
246 variable Lf
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
247 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
248
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
249 proc ::relmon::update::OnError {message returnOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
250 # internal error, abort
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
251 puts stderr [dict get $returnOptions "-errorinfo"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
252
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
253 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
254 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
255
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
256 proc ::relmon::update::CleanupBeforeExit {commandString operation} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
257 variable Lf
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
258
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
259 # close logfile
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
260 if {($Lf ne "") && ($Lf ni {stdin stderr})} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
261 close $Lf
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
262 set Lf ""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
263 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
264
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
265 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
266 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
267
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
268 proc ::relmon::update::ParseWatchlist {watchlistFilename} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
269 variable Watchlist
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
270
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
271 set lineno 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
272 set f [open $watchlistFilename "r"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
273 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
274 while {[chan gets $f line] != -1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
275 set fields [textutil::split::splitx [string trim $line] {[\t ]+}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
276 incr lineno
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
277
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
278 if {([llength $fields] == 0) ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
279 ([string index [lindex $fields 0] 0] eq "#")} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
280 # skip empty lines and comments
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
281 continue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
282 } elseif {[llength $fields] < 3} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
283 # a line consists of a name, base URL and at least one
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
284 # version-matching pattern
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
285 return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
286 "syntax error in \"$watchlistFilename\" line $lineno"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
287 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
288
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
289 set patterns [lassign $fields name baseUrl]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
290
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
291 # validate URL
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
292 if {![::relmon::common::isUrlValid $baseUrl]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
293 return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
294 "syntax error in \"$watchlistFilename\" line $lineno:\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
295 invalid base URL"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
296 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
297
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
298 # process patterns
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
299 set processedPatterns {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
300 set patternIndex 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
301 foreach pattern $patterns {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
302 incr patternIndex
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
303
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
304 # make trailing slashes optional except in the last
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
305 # version-matching pattern
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
306 if {($patternIndex != [llength $patterns]) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
307 ([string index $pattern end] eq "/")} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
308 append pattern {?}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
309 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
310
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
311 # ensure patterns are anchored to the end of the line
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
312 if {[string index $pattern end] ne "$"} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
313 append pattern {$}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
314 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
315
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
316 # actually validate the regular expression
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
317 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
318 set reInfo [regexp -about -- $pattern ""]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
319 } on error {errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
320 return -code error \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
321 -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
322 "error in \"$watchlistFilename\" line $lineno:\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
323 $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
324 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
325 lappend processedPatterns $pattern
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
326 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
327 if {[lindex $reInfo 0] < 1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
328 return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
329 "syntax error in \"$watchlistFilename\" line $lineno:\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
330 the last regular expression must contain at least one
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
331 capturing group"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
332 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
333
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
334 dict set Watchlist $name "base_url" $baseUrl
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
335 dict set Watchlist $name "patterns" $processedPatterns
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
336 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
337 } finally {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
338 close $f
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
339 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
340
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
341 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
342 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
343
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
344 proc ::relmon::update::ProcessHtmlElement {tag slash param textBehindTheTag} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
345 variable PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
346
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
347 # copy every "<a>" element into PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
348 if {($slash eq "") && ([string tolower $tag] eq "a")} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
349 append PreprocessedHtmlBuffer "<$tag $param></$tag>"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
350 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
351
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
352 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
353 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
354
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
355 proc ::relmon::update::PreprocessHtml {bodyDataName} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
356 upvar 1 $bodyDataName bodyData
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
357 variable PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
358
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
359 # preprocess the document with htmlparse by constructing a new document
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
360 # consisting only of found "<a>" elements which then can be fed into tdom
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
361 # again; this is useful if parsing via tdom fails; however, htmlparse
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
362 # should only be used as a last resort because it is just too limited, it
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
363 # gets easily confused within "<script>" elements and lacks attribute
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
364 # parsing
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
365 set PreprocessedHtmlBuffer "<html><body>"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
366 htmlparse::parse -cmd [namespace code ProcessHtmlElement] $bodyData
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
367 append PreprocessedHtmlBuffer "</body></html>"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
368 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
369
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
370 proc ::relmon::update::ExtractUrls {bodyDataName contentType baseUrl
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
371 rePattern} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
372 upvar 1 $bodyDataName bodyData
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
373 set extractedUrls {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
374 set resultUrls [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
375 # extract all URLs or URL fragments
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
376 switch -- $contentType {
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
377 {text/html} -
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
378 {application/xhtml+xml} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
379 # HTML/XHTML
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
380 # if tdom parsing has failed or not found any "<a>" element,
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
381 # preprocess the document with htmlparse and try again
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
382 if {[catch {dom parse -html $bodyData} doc] ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
383 ([set rootElement [$doc documentElement]] eq "") ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
384 ([llength [set aElements \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
385 [$rootElement selectNodes {descendant::a}]]] == 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
386 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
387 set doc [dom parse -html [PreprocessHtml bodyData]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
388 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
389 dict set errorOptions "-errorcode" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
390 {RELMON TDOM_PARSE_ERROR}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
391 return -options $errorOptions $errorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
392 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
393 set rootElement [$doc documentElement]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
394 set aElements [$rootElement selectNodes {descendant::a}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
395 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
396 foreach node $aElements {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
397 set href [$node getAttribute "href" ""]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
398 if {$href ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
399 lappend extractedUrls $href
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
400 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
401 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
402 $doc delete
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
403 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
404 {application/rss+xml} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
405 # RSS 2.0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
406 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
407 set doc [dom parse $bodyData]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
408 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
409 dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
410 return -options $errorOptions $errorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
411 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
412 set rootElement [$doc documentElement]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
413 if {$rootElement ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
414 foreach node [$rootElement selectNodes {descendant::link}] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
415 set linkText [$node text]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
416 if {$linkText ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
417 lappend extractedUrls $linkText
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
418 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
419 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
420 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
421 $doc delete
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
422 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
423 {application/atom+xml} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
424 # Atom 1.0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
425 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
426 set doc [dom parse $bodyData]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
427 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
428 dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
429 return -options $errorOptions $errorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
430 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
431 set rootElement [$doc documentElement]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
432 if {$rootElement ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
433 foreach node [$rootElement selectNodes {descendant::link}] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
434 set href [$node getAttribute "href" ""]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
435 if {$href ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
436 lappend extractedUrls $href
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
437 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
438 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
439 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
440 $doc delete
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
441 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
442 {text/plain} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
443 # plain text
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
444 foreach line [split $bodyData "\n"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
445 if {$line ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
446 lappend extractedUrls $line
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
447 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
448 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
449 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
450 default {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
451 return -code error \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
452 -errorcode {RELMON UNSUPPORTED_CONTENT_TYPE_ERROR} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
453 "unsupported content type \"$contentType\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
454 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
455 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
456 foreach url $extractedUrls {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
457 set normalizedUrl [uri::canonicalize [uri::resolve $baseUrl $url]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
458 dict set resultUrls $normalizedUrl \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
459 [expr {[regexp -line -- $rePattern $normalizedUrl] ? 1 : 0}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
460 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
461
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
462 return $resultUrls
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
463 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
464
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
465 proc ::relmon::update::StateItemAppendError {name logMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
466 variable StateBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
467
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
468 dict update StateBuffer $name stateItem {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
469 dict lappend stateItem "errors" $logMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
470 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
471
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
472 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
473 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
474
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
475 proc ::relmon::update::HandleSuccessfulTransfer {item httpBodyName} {
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
476 upvar 1 $httpBodyName httpBody
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
477 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
478 variable StateBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
479 variable Queue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
480 variable Watchlist
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
481
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
482 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
483 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
484 set patternIndex [dict get $item "pattern_index"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
485 set pattern [lindex [dict get $Watchlist $name "patterns"] $patternIndex]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
486
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
487 ${Log}::info "\"$name\": \"$url\": transfer finished"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
488
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
489 # parse data
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
490 try {
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
491 set urls [ExtractUrls httpBody [dict get $item "content_type"] $url \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
492 $pattern]
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
493 } trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
494 # continue on tdom parsing errors or when receiving documents with an
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
495 # unsupported content type
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
496 set urls [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
497 set warningMsg "\"$name\": \"$url\": failed to parse data: $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
498 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
499 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
500 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
501
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
502 if {$patternIndex < ([llength \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
503 [dict get $Watchlist $name "patterns"]] - 1)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
504 # if this is not the last, version-matching pattern, queue matched URLs
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
505 dict for {newUrl matched} $urls {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
506 if {$matched} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
507 if {![::relmon::common::isUrlValid $newUrl]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
508 ${Log}::debug "\"$name\": \"$url\": ignoring matched but\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
509 invalid URL \"$newUrl\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
510 continue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
511 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
512
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
513 ${Log}::debug "\"$name\": \"$url\": queuing \"$newUrl\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
514
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
515 dict lappend Queue [::relmon::common::urlGetHost $newUrl] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
516 [dict create "name" $name "url" $newUrl \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
517 "pattern_index" [expr {$patternIndex + 1}] \
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
518 "content_type" "" "num_redirects" 0 "num_retries" 0]
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
519 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
520 ${Log}::debug "\"$name\": \"$url\": ignoring \"$newUrl\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
521 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
522 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
523 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
524 # otherwise this branch has finished, try to extract the versions and
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
525 # store them in the buffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
526 dict for {finalUrl matched} $urls {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
527 if {$matched} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
528 regexp -line -- $pattern $finalUrl -> version
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
529 if {$version ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
530 ${Log}::debug "\"$name\": \"$url\": extracted version\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
531 \"$version\" from \"$finalUrl\" found on\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
532 \"$url\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
533 dict set StateBuffer $name "versions" $version $finalUrl
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
534 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
535 ${og}::debug "\"$name\": \"$url\": could not extract a\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
536 version from \"$finalUrl\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
537 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
538 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
539 ${Log}::debug "\"$name\": \"$url\": ignoring \"$finalUrl\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
540 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
541 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
542 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
543
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
544 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
545 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
546
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
547 proc ::relmon::update::HandleRedirect {item httpCode httpHeaders} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
548 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
549 variable Queue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
550
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
551 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
552 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
553
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
554 if {![dict exists $httpHeaders "Location"]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
555 # bail out in case of an invalid HTTP response
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
556 set warningMsg "\"$name\": \"$url\": transfer failed: invalid HTTP\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
557 response"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
558 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
559 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
560 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
561 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
562 set location [dict get $httpHeaders "Location"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
563
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
564 # sanitize URL from Location header
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
565 if {[uri::isrelative $location]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
566 set redirectUrl [uri::canonicalize [uri::resolve \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
567 $url $location]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
568 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
569 if {![::relmon::common::isUrlValid $location]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
570 # bail out in case of an invalid redirect URL
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
571 set warningMsg "\"$name\": \"$url\": received invalid redirect URL\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
572 \"$location\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
573 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
574 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
575 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
576 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
577 set redirectUrl [uri::canonicalize $location]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
578 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
579
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
580 ${Log}::notice "\"$name\": \"$url\": received redirect to \"$redirectUrl\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
581
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
582 # handle up to 10 redirects by re-queuing the target URL
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
583 if {[dict get $item "num_redirects"] < 10} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
584 ${Log}::debug "\"$name\": \"$url\": queuing \"$redirectUrl\" due to\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
585 redirect"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
586
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
587 dict lappend Queue [::relmon::common::urlGetHost $redirectUrl] \
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
588 [dict replace $item "url" $redirectUrl "content_type" "" \
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
589 "num_redirects" [expr {[dict get $item "num_redirects"] + 1}] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
590 "num_retries" 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
591 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
592 set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
593 redirects"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
594 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
595 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
596 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
597
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
598 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
599 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
600
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
601 proc ::relmon::update::HandleProtocolError {item httpCode} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
602 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
603 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
604 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
605 set warningMsg "\"$name\": \"$url\": transfer failed: $httpCode"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
606 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
607 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
608 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
609 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
610
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
611 proc ::relmon::update::HandleTimeoutReset {item} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
612 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
613 variable Config
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
614 variable Queue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
615 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
616 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
617
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
618 # retry by re-queuing the target URL until reaching the limit
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
619 if {[dict get $item "num_retries"] < [dict get $Config "retry_limit"]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
620 ${Log}::warn "\"$name\": \"$url\": connection timed out or was reset,\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
621 retrying"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
622 dict lappend Queue [::relmon::common::urlGetHost $url] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
623 [dict replace $item \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
624 "num_retries" [expr {[dict get $item "num_retries"] + 1}]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
625 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
626 set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
627 retries"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
628 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
629 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
630 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
631
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
632 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
633 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
634
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
635 proc ::relmon::update::HandleConnectionError {item errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
636 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
637 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
638 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
639 set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
640 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
641 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
642 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
643 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
644
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
645 proc ::relmon::update::TransferCallbackWrapper {callbackCmd args} {
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
646 # ensure that exceptions get raised, by default http catches all errors and
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
647 # silently ignores them, see https://core.tcl.tk/tcl/tktview?name=1414262
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
648 if {[catch {eval $callbackCmd $args} -> errorOptions]} {
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
649 OnError [dict get $errorOptions "-errorinfo"] $errorOptions
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
650 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
651 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
652 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
653
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
654 proc ::relmon::update::ManageTransfers {} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
655 variable Config
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
656 variable ManageTransfersId
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
657 variable Queue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
658 variable HostConnections
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
659 variable HostDelays
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
660 variable ActiveTransfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
661 variable ExitStatus
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
662 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
663
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
664 after cancel $ManageTransfersId
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
665
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
666 # try to initiate new transfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
667 while {([dict size $ActiveTransfers] <
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
668 [dict get $Config "connection_limit"]) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
669 ([dict size $Queue] > 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
670 # find URLs in the queue with a host for which we have not reached the
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
671 # per-host connection limit yet and for which no delay is in effect
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
672 set item {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
673 dict for {host items} $Queue {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
674 set now [clock milliseconds]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
675
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
676 if {![dict exists $HostConnections $host]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
677 dict set HostConnections $host 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
678 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
679
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
680 if {![dict exists $HostDelays $host]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
681 dict set HostDelays $host $now
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
682 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
683
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
684 if {([dict get $HostConnections $host] <
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
685 [dict get $Config "host_connection_limit"]) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
686 ([dict get $HostDelays $host] <= $now)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
687 # pop item from the queue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
688 set items [lassign $items item]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
689 if {[llength $items] > 0} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
690 dict set Queue $host $items
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
691 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
692 dict unset Queue $host
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
693 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
694
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
695 dict incr HostConnections $host
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
696 # set a random delay before the next connection to this host
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
697 # can be made
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
698 dict set HostDelays $host \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
699 [expr {[clock milliseconds] + int((rand() + 0.5) *
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
700 [dict get $Config "host_delay"])}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
701 break
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
702 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
703 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
704 # if no item could be found, the per-host connection limit for all
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
705 # queued URLs has been reached and no new transfers may be started
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
706 # at this point
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
707 if {$item eq {}} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
708 break
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
709 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
710 # otherwise start a new transfer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
711 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
712 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
713 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
714 set token [http::geturl $url \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
715 -timeout [dict get $Config "transfer_time_limit"] \
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
716 -progress [namespace code {TransferCallbackWrapper \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
717 OnTransferProgress}] \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
718 -command [namespace code {TransferCallbackWrapper \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
719 OnTransferFinished}]]
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
720 } on ok {} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
721 dict set ActiveTransfers $token $item
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
722
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
723 ${Log}::info "\"$name\": \"$url\": starting transfer"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
724 } on error {errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
725 # an error occured during socket setup, e.g. a DNS lookup failure
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
726 set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
727 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
728 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
729 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
730 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
731
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
732 # terminate the event loop if there are no remaining transfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
733 if {([dict size $ActiveTransfers]) == 0 && ([dict size $Queue] == 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
734 set ExitStatus 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
735 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
736 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
737
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
738 # due to per-host connection limits and per-host delays the maximum number
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
739 # of connections may not be reached although there are still items in the
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
740 # queue, in this case schedule ManageTransfers again after the smallest of
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
741 # the current per-host delays
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
742 set delay 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
743 if {([dict size $ActiveTransfers] <
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
744 [dict get $Config "connection_limit"]) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
745 ([dict size $Queue] > 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
746 dict for {host items} $Queue {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
747 if {(![dict exists $HostConnections $host] ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
748 ([dict get $HostConnections $host] <
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
749 [dict get $Config "host_connection_limit"])) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
750 ([dict exists $HostDelays $host] &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
751 ([dict get $HostDelays $host] > $now))} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
752 set hostDelay [expr {[dict get $HostDelays $host] - $now + 1}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
753 if {(($delay == 0) ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
754 ($hostDelay < $delay))} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
755 set delay $hostDelay
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
756 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
757 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
758 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
759 if {$delay > 0} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
760 set ManageTransfersId \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
761 [after $delay [namespace code ManageTransfers]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
762 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
763 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
764
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
765 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
766 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
767
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
768 proc ::relmon::update::OnTransferProgress {token total current} {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
769 upvar #0 $token httpState
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
770 variable ActiveTransfers
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
771 variable Log
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
772
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
773 # try to determine content type and abort transfer if content type is not
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
774 # one that can be parsed, this is primarily to prevent accidental downloads
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
775 if {[dict get $ActiveTransfers $token "content_type"] eq ""} {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
776 set httpHeaders [relmon::common::normalizeHttpHeaders \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
777 $httpState(meta)]
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
778
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
779 if {[dict exists $httpHeaders "Content-Type"]} {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
780 set contentType [string trim [lindex [split \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
781 [dict get $httpHeaders "Content-Type"] ";"] 0]]
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
782 dict set ActiveTransfers $token "content_type" $contentType
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
783 if {$contentType ni {"text/html" "application/xhtml+xml"
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
784 "application/atom+xml" "application/rss+xml"
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
785 "text/plain"}} {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
786 ${Log}::warn "\"[dict get $ActiveTransfers $token "name"]\":\
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
787 \"[dict get $ActiveTransfers $token "url"]\": content\
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
788 type \"$contentType\" is not acceptable"
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
789 http::reset $token
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
790 }
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
791 }
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
792 }
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
793 }
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
794
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
795 proc ::relmon::update::OnTransferFinished {token} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
796 upvar #0 $token httpState
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
797 variable Config
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
798 variable HostConnections
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
799 variable Queue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
800 variable ActiveTransfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
801 variable Statistics
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
802 variable StateBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
803 variable State
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
804 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
805
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
806 set item [dict get $ActiveTransfers $token]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
807 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
808 set host [relmon::common::urlGetHost [dict get $item "url"]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
809
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
810 # update list of per-host connections, and number of remaining transfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
811 # for this item
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
812 dict unset ActiveTransfers $token
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
813 dict incr HostConnections $host -1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
814
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
815 switch -- $httpState(status) {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
816 {ok} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
817 # normalize headers
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
818 set httpHeaders [relmon::common::normalizeHttpHeaders \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
819 $httpState(meta)]
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
820
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
821 # try to determine content type
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
822 if {([dict get $item "content_type"] eq "") &&
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
823 [dict exists $httpHeaders "Content-Type"]} {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
824 dict set item "content_type" [string trim [lindex [split \
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
825 [dict get $httpHeaders "Content-Type"] ";"] 0]]
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
826 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
827
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
828 # dispatch based on HTTP status code
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
829 set httpCode [http::ncode $token]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
830 switch -glob -- $httpCode {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
831 {30[12378]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
832 HandleRedirect $item $httpCode $httpHeaders
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
833 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
834 {200} {
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
835 HandleSuccessfulTransfer $item httpState(body)
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
836 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
837 default {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
838 HandleProtocolError $item $httpState(http)
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
839 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
840 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
841 }
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
842 {reset} {
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
843 # aborted due to wrong content type
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
844 }
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
845 {eof} -
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
846 {timeout} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
847 # timeout or connection reset
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
848 HandleTimeoutReset $item
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
849 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
850 {error} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
851 # connection may have failed or been refused
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
852 HandleConnectionError $item [lindex $httpState(error) 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
853 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
854 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
855
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
856 # check if all transfers of this item are finished
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
857 set itemFinished 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
858 dict for {queueHost queueItems} $Queue {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
859 foreach queueItem $queueItems {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
860 if {[dict get $queueItem "name"] eq $name} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
861 set itemFinished 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
862 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
863 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
864 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
865 dict for {activeToken activeItem} $ActiveTransfers {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
866 if {[dict get $activeItem "name"] eq $name} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
867 set itemFinished 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
868 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
869 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
870 if {$itemFinished} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
871 set timestamp [clock milliseconds]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
872
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
873 # create httpState item if it does not exist yet
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
874 if {![dict exists $State $name]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
875 dict set State $name [dict create "versions" [dict create] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
876 "history" [list] "timestamp" 0 "errors" [list]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
877 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
878
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
879 # if there are no versions, log an error message since something must
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
880 # be wrong
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
881 if {[llength [dict get $StateBuffer $name "versions"]] == 0} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
882 set warningMsg "\"$name\": no versions found"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
883 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
884 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
885 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
886
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
887 # update httpState item
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
888 dict set State $name "errors" [dict get $StateBuffer $name "errors"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
889 dict set State $name "timestamp" $timestamp
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
890 if {[llength [dict get $StateBuffer $name "errors"]] == 0} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
891 # expire old history entries
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
892 set history [lrange [dict get $State $name "history"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
893 [expr {[llength [dict get $State $name "history"]] -
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
894 [dict get $Config "history_limit"] + 1}] end]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
895
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
896 # add currently latest available version to history if it is either
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
897 # newer than the previous one or if the previous one is no longer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
898 # available (e.g. if it has been removed or the watchlist pattern
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
899 # has been changed)
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
900 set prevLatestVersion [lindex $history end 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
901 set curLatestVersion [lindex \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
902 [lsort -command ::relmon::common::cmpVersion \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
903 [dict keys [dict get $StateBuffer $name "versions"]]] end]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
904 if {([::relmon::common::cmpVersion $curLatestVersion \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
905 $prevLatestVersion] > 0) ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
906 ![dict exists $StateBuffer $name "versions" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
907 $prevLatestVersion]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
908 lappend history [list $curLatestVersion $timestamp]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
909 dict set State $name "history" $history
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
910 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
911 dict set State $name "versions" [dict get $StateBuffer $name \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
912 "versions"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
913 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
914 dict unset StateBuffer $name
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
915
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
916 ${Log}::notice "progress: [dict size $StateBuffer]/[dict get \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
917 $Statistics "items"] items left"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
918 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
919
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
920 http::cleanup $token
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
921
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
922 ManageTransfers
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
923
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
924 return
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
925 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
926
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
927 # control certificate verification and log errors during TLS handshake
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
928 proc ::relmon::update::OnTlsHandshake {type args} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
929 variable Config
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
930 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
931
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
932 switch -- ${type} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
933 {error} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
934 lassign $args {} tlsErrorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
935 ${Log}::error "TLS connection error: $tlsErrorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
936 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
937 {verify} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
938 lassign $args {} {} {} status tlsErrorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
939 array set cert [lindex $args 2]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
940 if {$status == 0} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
941 if {[dict get $Config "ca_dir"] eq ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
942 # do not verify certificates is ca-dir was not set
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
943 return 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
944 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
945 set errorMsg "$tlsErrorMsg\nCertificate details:"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
946 foreach {key description} {"serial" "Serial Number"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
947 "issuer" "Issuer" "notBefore" "Not Valid Before"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
948 "notAfter" "Not Valid After" "subject" "Subject"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
949 "sha1_hash" "SHA1 Hash"} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
950 append errorMsg "\n$description: $cert($key)"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
951 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
952 ${Log}::error "TLS connection error: $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
953 return 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
954 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
955 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
956 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
957 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
958 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
959
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
960 proc ::relmon::update::main {args} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
961 variable Config
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
962 variable usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
963 variable Statistics
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
964 variable Watchlist [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
965 variable Queue [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
966 variable HostConnections [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
967 variable HostDelays [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
968 variable ActiveTransfers [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
969 variable State
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
970 variable StateBuffer [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
971 variable PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
972 variable Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
973 variable Lf ""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
974 variable ExitStatus
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
975
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
976 # parse commandline
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
977 while {[set GetoptRet [cmdline::getopt args \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
978 {c.arg C.arg d D.arg e H.arg i.arg l.arg r.arg t.arg T.arg v} \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
979 OptArg OptVal]] == 1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
980 switch -glob -- $OptArg {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
981 {c} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
982 if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
983 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
984 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
985 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
986 dict set Config "host_connection_limit" $OptVal
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
987 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
988 {C} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
989 if {![file isdirectory $OptVal]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
990 puts stderr "directory \"$OptVal\" is not a directory"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
991 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
992 } elseif {![file readable $OptVal] ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
993 ![file executable $OptVal]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
994 puts stderr "directory \"$OptVal\" is not readable"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
995 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
996 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
997 dict set Config "ca_dir" $OptVal
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
998 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
999 {d} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1000 dict set Config "log_level" "debug"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1001 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1002 {D} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1003 if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1004 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1005 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1006 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1007 dict set Config "host_delay" [expr {$OptVal * 1000}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1008 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1009 {e} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1010 dict set Config "error_filter" 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1011 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1012 {H} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1013 if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1014 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1015 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1016 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1017 dict set Config "connection_limit" $OptVal
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1018 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1019 {i} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1020 foreach item [split $OptVal " "] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1021 set item [string trim $item]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1022 if {$item ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1023 dict lappend Config "item_filter" $item
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1024 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1025 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1026 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1027 {l} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1028 dict set Config "log_file" $OptVal
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1029 set LogDir [file dirname $OptVal]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1030 if {![file writable $LogDir] || ![file executable $LogDir]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1031 puts stderr "directory \"$LogDir\" is not writable"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1032 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1033 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1034 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1035 {r} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1036 if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1037 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1038 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1039 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1040 dict set Config "retry_limit" $OptVal
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1041 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1042 {t} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1043 if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1044 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1045 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1046 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1047 dict set Config "timestamp_filter" [expr {$OptVal * 1000}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1048 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1049 {T} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1050 if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1051 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1052 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1053 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1054 dict set Config "transfer_time_limit" [expr {$OptVal * 1000}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1055 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1056 {v} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1057 if {[dict get $Config "log_level"] ne "debug"} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1058 dict set Config "log_level" "info"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1059 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1060 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1061 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1062 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1063 set argc [llength $args]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1064 if {$GetoptRet == -1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1065 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1066 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1067 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1068 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1069 if {$argc != 2} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1070 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1071 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1072 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1073 dict set Config "watchlist_file" [lindex $args 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1074 if {![file readable [dict get $Config "watchlist_file"]]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1075 puts stderr "watchlist file \"[dict get $Config "watchlist_file"]\"\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1076 could not be read"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1077 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1078 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1079 set stateFile [lindex $args 1]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1080 dict set Config "state_file" $stateFile
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1081 set StateDir [file dirname $stateFile]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1082 if {![file writable $StateDir]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1083 puts stderr "directory \"$StateDir\" is not writable"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1084
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1085 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1086 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1087
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1088 # install exit handler for closing the logfile, open the logfile and
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1089 # initialize logger
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1090 trace add execution exit enter CleanupBeforeExit
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1091 if {[dict get $Config "log_file"] ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1092 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1093 set Lf [open [dict get $Config "log_file"] "w"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1094 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1095 puts stderr "failed to open logfile\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1096 \"[dict get $Config "log_file"]\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1097 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1098 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1099 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1100 set Lf stderr
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1101 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1102 set Log [logger::init global]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1103 if {[dict get $Config "log_level"] eq "debug"} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1104 set logFormat {%d \[%p\] \[%M\] %m}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1105 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1106 set logFormat {%d \[%p\] %m}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1107 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1108 logger::utils::applyAppender -appender fileAppend -appenderArgs \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1109 [list -outputChannel $Lf -conversionPattern $logFormat] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1110 -serviceCmd $Log
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1111
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1112 # set default logging level
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1113 ${Log}::setlevel [dict get $Config "log_level"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1114
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1115 ${Log}::notice "relmon.tcl starting up"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1116
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1117 # parse the watchlist
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1118 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1119 ParseWatchlist [dict get $Config "watchlist_file"]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1120 } trap {POSIX} {errorMsg errorOptions} - \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1121 trap {RELMON} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1122 ${Log}::error $errorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1123 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1124 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1125
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1126 # read the state file
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1127 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1128 set State [::relmon::common::parseStateFile $stateFile]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1129 } trap {POSIX ENOENT} {errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1130 ${Log}::debug "state file \"$stateFile\" does not exist"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1131 set State [dict create]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1132 } trap {POSIX} {errorMsg} - \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1133 trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1134 ${Log}::error $errorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1135 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1136 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1137
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1138 # initialize queue and state buffer from the watchlist
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1139 dict set Statistics "start_time" [clock milliseconds]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1140 dict for {name watchlistItem} $Watchlist {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1141 # apply filters specified on the command line to watchlist items
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1142 if {([llength [dict get $Config "item_filter"]] > 0) &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1143 ($name ni [dict get $Config "item_filter"])} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1144 continue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1145 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1146
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1147 if {[dict get $Config "error_filter"] &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1148 [dict exists $State $name "errors"] &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1149 ([llength [dict get $State $name "errors"]] == 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1150 continue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1151 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1152
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1153 if {[dict exists $State $name "timestamp"] &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1154 ([dict get $State $name "timestamp"] >
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1155 [dict get $Statistics "start_time"] -
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1156 [dict get $Config "timestamp_filter"])} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1157 continue
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1158 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1159
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1160 dict lappend Queue [::relmon::common::urlGetHost \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1161 [dict get $watchlistItem "base_url"]] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1162 [dict create \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1163 "name" $name \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1164 "url" [dict get $watchlistItem "base_url"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1165 "pattern_index" 0 \
1
cba4887feb2c Check the content type of documents that are being downloaded
Guido Berhoerster <guido+relmon@berhoerster.name>
parents: 0
diff changeset
1166 "content_type" "" \
0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1167 "num_redirects" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1168 "num_retries" 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1169 dict incr Statistics "items"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1170 dict set StateBuffer $name [dict create "versions" [dict create] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1171 "errors" [list]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1172 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1173
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1174 # configure http and tls
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1175 http::register https 443 [list tls::socket \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1176 -cadir [dict get $Config "ca_dir"] -request 1 -require 1 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1177 -command [namespace code OnTlsHandshake] -ssl2 0 -ssl3 1 -tls1 1]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1178 http::config -useragent "Mozilla/5.0 (Windows NT 6.1; rv:16.0)\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1179 Gecko/20100101 Firefox/16.0 relmon/$relmon::VERSION"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1180
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1181 # handle errors while in the event loop
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1182 interp bgerror {} [namespace code OnError]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1183
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1184 # enter the main loop
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1185 after idle [namespace code ManageTransfers]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1186 vwait [namespace which -variable ExitStatus]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1187
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1188 dict set Statistics "end_time" [clock milliseconds]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1189
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1190 # display statistics
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1191 ${Log}::notice "items checked: [dict get $Statistics "items"]"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1192 ${Log}::notice "time elapsed: [expr {([dict get $Statistics "end_time"] -
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1193 [dict get $Statistics "start_time"]) / 1000}]s"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1194
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1195 # serialize the new state
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1196 set JsonStateItems {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1197 dict for {item data} $State {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1198 set versions {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1199 dict for {version url} [dict get $data "versions"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1200 lappend versions $version [json::write string $url]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1201 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1202 set history {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1203 foreach historyItem [dict get $data "history"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1204 lassign $historyItem version timestamp
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1205 lappend history [json::write array [json::write string $version] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1206 $timestamp]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1207 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1208 set errors {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1209 foreach errorItem [dict get $data "errors"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1210 lappend errors [json::write string $errorItem]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1211 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1212 lappend JsonStateItems $item [json::write object \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1213 "versions" [json::write object {*}$versions] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1214 "history" [json::write array {*}$history] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1215 "timestamp" [dict get $data "timestamp"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1216 "errors" [json::write array {*}$errors]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1217 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1218 set JsonState [json::write object {*}$JsonStateItems]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1219
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1220 # try to preserve permissions and ownership
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1221 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1222 set stateFileAttributes [file attributes $stateFile]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1223 } trap {POSIX ENOENT} {} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1224 set stateFileAttributes {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1225 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1226 ${Log}::error "failed to stat \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1227 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1228 # write the new state to a temporary file
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1229 set tmpFile "$stateFile.[pid].tmp"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1230 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1231 set f [open $tmpFile {RDWR CREAT EXCL TRUNC} 0600]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1232 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1233 ${Log}::error "failed to open \"$tmpFile\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1234
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1235 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1236 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1237 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1238 chan puts -nonewline $f $JsonState
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1239 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1240 catch {file delete $tmpFile}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1241
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1242 ${Log}::error "failed to write to \"$tmpFile\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1243
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1244 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1245 } finally {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1246 close $f
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1247 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1248 # make a backup of the previous state file
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1249 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1250 file copy -force $stateFile "$stateFile~"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1251 } trap {POSIX ENOENT} {} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1252 # ignore non-existing file
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1253 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1254 ${Log}::error "failed to create a backup of \"$statFile\":\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1255 $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1256 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1257 # rename the temporary file to the state file name
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1258 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1259 file rename -force $tmpFile $stateFile
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1260 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1261 catch {file delete $tmpFile}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1262
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1263 ${Log}::error "failed to rename \"$tmpFile\" to \"$stateFile\":\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1264 $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1265
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1266 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1267 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1268 # restore ownership and permissions
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1269 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1270 file attributes $stateFile {*}$stateFileAttributes
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1271 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1272 ${Log}::error "failed to set permissions and ownership on\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1273 \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1274
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1275 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1276 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1277
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1278 # clean up
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1279 ${Log}::delete
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1280
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1281 exit $ExitStatus
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1282 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1283
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1284
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1285 namespace eval ::relmon::show {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1286 # commandline option help text
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1287 variable usage "usage: relmon show statefile name..."
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1288 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1289
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1290 proc ::relmon::show::GetItem {stateName name} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1291 upvar 1 $stateName state
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1292 set item [dict get $state $name]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1293
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1294 # format state data as plain-text
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1295 set output ""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1296 append output "Name: $name\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1297 append output "Latest Version:\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1298 [lindex [lindex [dict get $item "history"] end] 0]\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1299 append output "Refreshed: [clock format \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1300 [expr {[dict get $item "timestamp"] / 1000}] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1301 -format {%Y-%m-%dT%H:%M:%S%z}]\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1302 append output "Versions:\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1303 dict for {version url} [dict get $item "versions"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1304 append output "\t$version $url\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1305 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1306 append output "Errors:\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1307 if {[dict get $item "errors"] eq ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1308 append output "\tNone\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1309 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1310 foreach errorMsg [dict get $item "errors"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1311 append output "\t[string map {\n \n\t} [string trim $errorMsg]]\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1312 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1313 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1314 append output "History:\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1315 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1316 append output "\t[lindex $historyItem 0] [clock format \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1317 [expr {[lindex $historyItem 1] / 1000}] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1318 -format {%Y-%m-%dT%H:%M:%S%z}]\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1319 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1320 return $output
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1321 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1322
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1323 proc ::relmon::show::main {args} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1324 variable usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1325
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1326 # parse commandline
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1327 if {[cmdline::getopt args {} OptArg OptVal] == -1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1328 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1329 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1330 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1331 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1332 if {[llength $args] < 2} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1333 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1334 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1335 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1336 set stateFile [lindex $args 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1337 set names [lrange $args 1 end]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1338
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1339 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1340 set state [::relmon::common::parseStateFile $stateFile]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1341 } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1342 puts stderr $errorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1343 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1344 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1345
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1346 # show each item
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1347 foreach name $names {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1348 puts -nonewline [GetItem state $name]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1349 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1350
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1351 exit 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1352 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1353
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1354
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1355 namespace eval ::relmon::list {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1356 # commandline option help text
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1357 variable usage "usage: relmon list \[-H\] \[-f html|parseable|text\]\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1358 \[-F url\]\n\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1359 \ \[-n number_items\] statefile\n\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1360 \ relmon list -f atom -F url \[-n number_items\] statefile"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1361
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1362 # configuration options
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1363 variable Config [dict create \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1364 "format" "text" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1365 "show_history" 0 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1366 "history_limit" 100 \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1367 "feed_url" ""]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1368 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1369
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1370 proc ::relmon::list::FormatText {stateName includeHistory historyLimit} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1371 upvar 1 $stateName state
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1372 set output ""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1373 append output [format "%-35s %-15s %-24s %-3s\n" "Project" "Version" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1374 "Refreshed" "St."]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1375 append output [string repeat "-" 80]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1376 append output "\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1377
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1378 set history {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1379 dict for {name item} $state {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1380 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1381 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1382 [lindex $historyItem 0]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1383 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1384 set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1385 set timestamp [clock format [expr {[dict get $item "timestamp"] /
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1386 1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1387 set status [expr {[llength [dict get $item "errors"]] > 0 ? "E" : ""}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1388 append output [format "%-35s %15s %-24s %-1s\n" $name $latestVersion \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1389 $timestamp $status]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1390 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1391 if {$includeHistory} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1392 append output "\nHistory\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1393 append output [string repeat "-" 80]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1394 append output "\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1395 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1396 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1397 append output [format "%-24s %-35s %15s\n" \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1398 [clock format [expr {[lindex $historyItem 0] / 1000}] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1399 -format {%Y-%m-%dT%H:%M:%S%z}] [lindex $historyItem 1] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1400 [lindex $historyItem 2]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1401 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1402 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1403
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1404 return $output
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1405 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1406
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1407 proc ::relmon::list::FormatParseable {stateName includeHistory historyLimit} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1408 upvar 1 $stateName state
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1409 set output ""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1410 set history {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1411 dict for {name item} $state {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1412 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1413 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1414 [lindex $historyItem 0]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1415 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1416 set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1417 if {$latestVersion eq ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1418 set latestVersion -
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1419 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1420 set timestamp [clock format [expr {[dict get $item "timestamp"] /
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1421 1000}] -timezone :UTC -format {%Y-%m-%dT%H:%M:%SZ}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1422 set status [expr {[llength [dict get $item "errors"]] > 0 ? "ERROR" :
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1423 "OK"}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1424 append output [format "%s\t%s\t%s\t%s\n" $name $latestVersion \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1425 $timestamp $status]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1426 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1427 if {$includeHistory} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1428 append output "\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1429 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1430 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1431 append output [format "%s\t%s\t%s\n" [clock format \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1432 [expr {[lindex $historyItem 0] / 1000}] -timezone :UTC \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1433 -format {%Y-%m-%dT%H:%M:%SZ}] [lindex $historyItem 1] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1434 [lindex $historyItem 2]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1435 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1436 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1437 return $output
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1438 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1439
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1440 proc ::relmon::list::FormatHtml {stateName includeHistory historyLimit
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1441 feedUrl} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1442 upvar 1 $stateName state
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1443
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1444 set output "<html>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1445 append output "<head>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1446 append output "<title>Current Releases</title>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1447 if {$feedUrl ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1448 append output "<link type=\"application/atom+xml\" rel=\"alternate\"\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1449 title=\"Release History\"\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1450 href=\"[html::html_entities $feedUrl]\"/>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1451 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1452 append output "</head>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1453 append output "<body>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1454 append output "<h1>Current Releases</h1>\n<table>\n<tr>\n<th>Project</th>\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1455 \n<th>Version</th>\n<th>Refreshed</th>\n<th>Status</th>\n</tr>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1456 set history {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1457 dict for {name item} $state {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1458 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1459 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1460 [lindex $historyItem 0]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1461 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1462 set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1463 set timestamp [clock format [expr {[dict get $item "timestamp"] /
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1464 1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1465 set status [expr {[llength [dict get $item "errors"]] > 0 ? "Error" :
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1466 "OK"}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1467
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1468 append output "<tr>\n<td>[html::html_entities $name]</td>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1469 if {$latestVersion ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1470 if {[dict exists $item "versions" $latestVersion]} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1471 set url [dict get $item "versions" $latestVersion]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1472 append output "<td><a\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1473 href=\"[html::html_entities $url]\"\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1474 title=\"[html::html_entities\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1475 "$name $latestVersion"]\">[html::html_entities \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1476 $latestVersion]</a></td>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1477 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1478 append output "<td>[html::html_entities \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1479 $latestVersion]</td>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1480 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1481 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1482 append output "<td></td>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1483 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1484 append output "<td>$timestamp</td>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1485 append output "<td>[html::html_entities $status]</td>\n</tr>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1486 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1487 append output "</table>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1488
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1489 if {$includeHistory} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1490 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1491 append output "<h1>Release History</h1>\n<table>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1492 append output "<tr><th>Time</th><th>Project</th><th>Version</th></tr>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1493 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1494 set timestamp [clock format [expr {[lindex $historyItem 0] /
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1495 1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1496 set name [lindex $historyItem 1]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1497 set version [lindex $historyItem 2]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1498 append output "<tr>\n<td>$timestamp</td>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1499 append output "<td>[html::html_entities $name]</td>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1500 append output "<td>[html::html_entities $version]</td></tr>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1501 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1502 append output "</table>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1503 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1504
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1505 append output "</body>\n</html>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1506
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1507 return $output
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1508 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1509
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1510 proc ::relmon::list::FormatAtom {stateName historyLimit feedUrl} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1511 upvar 1 $stateName state
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1512 set host [::relmon::common::urlGetHost $feedUrl]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1513 set output "<?xml version=\"1.0\" encoding=\"utf-8\"?>\
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1514 \n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1515 append output "<author><name>relmon</name></author>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1516 append output "<title>Release History</title>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1517 append output "<id>[html::html_entities $feedUrl]</id>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1518 set history {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1519 dict for {name item} $state {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1520 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1521 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1522 [lindex $historyItem 0]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1523 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1524 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1525 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1526 set updated [lindex [lindex $history end] 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1527 if {$updated eq ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1528 set updated [clock seconds]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1529 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1530 append output "<updated>[clock format $updated \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1531 -format {%Y-%m-%dT%H:%M:%S%z}]</updated>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1532 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1533 set name [lindex $historyItem 1]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1534 set version [lindex $historyItem 2]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1535 set timestamp [clock format [expr {[lindex $historyItem 0] / 1000}] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1536 -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1537 set id "tag:$host,[clock format [lindex $historyItem 0] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1538 -format {%Y-%m-%d}]:[uri::urn::quote $name-$version]"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1539 append output "<entry>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1540 append output "<id>[html::html_entities $id]</id>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1541 append output "<updated>$timestamp</updated>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1542 append output "<title>[html::html_entities "$name $version"]</title>"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1543 append output "<content>[html::html_entities \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1544 "$name $version"]</content>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1545 append output "</entry>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1546 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1547 append output "</feed>\n"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1548 return $output
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1549 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1550
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1551 proc ::relmon::list::main {args} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1552 variable usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1553 variable Config
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1554
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1555 # parse commandline
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1556 while {[set GetoptRet [cmdline::getopt args {f.arg F.arg H n.arg} OptArg \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1557 OptVal]] == 1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1558 switch -glob -- $OptArg {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1559 {f} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1560 if {$OptVal ni {atom html parseable text}} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1561 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1562 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1563 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1564 dict set Config "format" $OptVal
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1565 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1566 {F} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1567 if {[catch {dict create {*}[uri::split $OptVal]} UrlParts] ||
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1568 ([dict get $UrlParts "host"] eq "")} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1569 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1570 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1571 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1572 dict set Config "feed_url" $OptVal
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1573 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1574 {H} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1575 dict set Config "show_history" 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1576 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1577 {n} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1578 if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1579 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1580 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1581 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1582 dict set Config "history_limit" [expr {$OptVal - 1}]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1583 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1584 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1585 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1586 set argc [llength $args]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1587 if {$GetoptRet == -1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1588 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1589 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1590 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1591 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1592 if {$argc != 1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1593 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1594 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1595 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1596 if {([dict get $Config "format"] eq "atom") &&
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1597 ([dict get $Config "feed_url"] eq "")} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1598 puts stderr "mandatory \"-F\" option is missing"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1599 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1600 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1601 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1602 set StateFile [lindex $args 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1603
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1604 # read the state file
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1605 try {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1606 set State [::relmon::common::parseStateFile $StateFile]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1607 } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1608 puts stderr $errorMsg
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1609 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1610 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1611
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1612 # call formatter
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1613 switch -- [dict get $Config "format"] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1614 {atom} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1615 puts -nonewline [FormatAtom State \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1616 [dict get $Config "history_limit"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1617 [dict get $Config "feed_url"]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1618 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1619 {html} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1620 puts -nonewline [FormatHtml State \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1621 [dict get $Config "show_history"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1622 [dict get $Config "history_limit"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1623 [dict get $Config "feed_url"]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1624 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1625 {parseable} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1626 puts -nonewline [FormatParseable State \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1627 [dict get $Config "show_history"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1628 [dict get $Config "history_limit"]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1629 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1630 {default} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1631 puts -nonewline [FormatText State \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1632 [dict get $Config "show_history"] \
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1633 [dict get $Config "history_limit"]]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1634 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1635 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1636
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1637 exit 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1638 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1639
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1640
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1641 namespace eval ::relmon::help {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1642 # commandline option help text
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1643 variable usage "usage: relmon help \[subcommand\]"
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1644 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1645
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1646 proc ::relmon::help::main {args} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1647 variable usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1648
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1649 # parse commandline
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1650 if {[cmdline::getopt args {} OptArg OptVal] == -1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1651 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1652 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1653 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1654 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1655 set argc [llength $args]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1656 if {$argc > 1} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1657 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1658 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1659 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1660 set subCommand [lindex $args 0]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1661 if {$subCommand ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1662 if {[info procs ::relmon::${subCommand}::main] ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1663 puts stderr [set ::relmon::${subCommand}::usage]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1664 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1665 puts stderr "unknown subcommand \"$subCommand\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1666 puts stderr $usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1667 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1668 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1669 } else {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1670 foreach subCommandNs [namespace children ::relmon] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1671 if {[info procs ${subCommandNs}::main] ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1672 puts stderr [set ${subCommandNs}::usage]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1673 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1674 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1675 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1676 exit 0
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1677 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1678
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1679
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1680 proc ::relmon::main {args} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1681 variable usage
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1682 set subArgs [lassign $args subCommand]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1683
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1684 # generate list of subcommands
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1685 set subCommands {}
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1686 foreach subCommandNs [namespace children ::relmon] {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1687 if {[info procs ${subCommandNs}::main] ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1688 lappend subCommands [namespace tail $subCommandNs]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1689 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1690 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1691 if {$subCommand ni $subCommands} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1692 if {$subCommand ne ""} {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1693 puts stderr "unknown subcommand \"$subCommand\""
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1694 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1695 foreach command $subCommands {
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1696 puts stderr [set relmon::${command}::usage]
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1697 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1698 exit 1
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1699 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1700
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1701 # dispatch subcommand
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1702 relmon::${subCommand}::main {*}$subArgs
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1703 }
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1704
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1705
8c5330f6e9e4 Initial revision
Guido Berhoerster <guido+relmon@berhoerster.name>
parents:
diff changeset
1706 relmon::main {*}$argv