projects/relmon: relmon.tcl.in annotate

annotate relmon.tcl.in @ 6:45fe94dbc236

Added tag version-1 for changeset 86a0c5d11f05

author	Guido Berhoerster <guido+relmon@berhoerster.name>
date	Fri, 07 Nov 2014 20:54:29 +0100
parents	86a0c5d11f05
children

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
3 6d87242c537e Add Makefile Guido Berhoerster <guido+relmon@berhoerster.name> parents: 1 diff changeset	44 variable VERSION @VERSION@
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	45
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	46 # default log format
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	47 variable LogFormatDefault {%d \[%p\] %m}
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	48
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	49 # debugging log format
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	50 variable LogFormatDebug {%d \[%p\] \[%M\] %m}
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	54 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	55 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	56 parseStateFile
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	57 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	58
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	59 # implementation of the Debian version comparison algorithm described at
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	60 # 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	61 proc ::relmon::common::cmpVersion {v1 v2} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	62 set v1Len [string length $v1]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	63 set v2Len [string length $v2]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	64 set v1Pos 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	65 set v2Pos 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	66 while {($v1Pos < $v1Len) \|\| ($v2Pos < $v2Len)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	67 set firstNumDiff 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	68 # until reaching ASCII digits in both version strings compare character
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	69 # values which are modified as so they are sorted in the following
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	70 # order:
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	71 # - "~"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	72 # - missing character or ASCII digits
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	73 # - ASCII alphabet
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	74 # - everything else in the order of their unicode value
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	75 while {(($v1Pos < $v1Len) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	76 ![string match {[0123456789]} [string index $v1 $v1Pos]]) \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	77 (($v2Pos < $v2Len) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	78 ![string match {[0123456789]} [string index $v2 $v2Pos]])} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	79 foreach char [list [string index $v1 $v1Pos] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	80 [string index $v2 $v2Pos]] charValueName \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	81 {v1CharValue v2CharValue} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	82 if {$char eq "~"} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	83 set $charValueName -1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	84 } elseif {$char eq ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	85 set $charValueName 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	86 } elseif {[string match {[0123456789]} $char]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	87 set $charValueName 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	88 } elseif {[string match -nocase {[abcdefghijklmnopqrstuvwxyz]} \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	89 $char]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	90 set $charValueName [scan $char "%c"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	91 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	92 set $charValueName [expr {[scan $char "%c"] + 0x7f + 1}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	93 }
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 if {$v1CharValue != $v2CharValue} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	96 return [expr {$v1CharValue - $v2CharValue}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	97 }
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 incr v2Pos
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	100 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	101
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	102 # strip leading zeros
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	103 while {[string index $v1 $v1Pos] eq "0"} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	104 incr v1Pos
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	105 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	106 while {[string index $v2 $v2Pos] eq "0"} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	107 incr v2Pos
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	108 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	109
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	110 # process digits until reaching a non-digit
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	111 while {[string match {[0123456789]} [string index $v1 $v1Pos]] &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	112 [string match {[0123456789]} [string index $v2 $v2Pos]]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	113 # record the first difference between the two numbers
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	114 if {$firstNumDiff == 0} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	115 set firstNumDiff [expr {[string index $v1 $v1Pos] -
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	116 [string index $v2 $v2Pos]}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	117 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	118 incr v1Pos
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	119 incr v2Pos
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	120 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	121
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	122 # 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	123 # since the one with more digits is the larger number
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	124 if {[string match {[0123456789]} [string index $v1 $v1Pos]]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	125 return 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	126 } elseif {[string match {[0123456789]} [string index $v2 $v2Pos]]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	127 return -1
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 the difference if the digits differed above
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	131 if {$firstNumDiff != 0} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	132 return $firstNumDiff
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	133 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	134 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	135
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	136 return 0
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::isUrlValid {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 "scheme"] in {"http" "https"}) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	142 ([dict get $urlParts "host"] ne "")}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	143 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	144
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	145 proc ::relmon::common::urlGetHost {url} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	146 return [expr {(![catch {dict create {*}[uri::split $url]} urlParts]) ?
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	147 [dict get $urlParts "host"] : ""}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	148 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	149
1 cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	150 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	151 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	152 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	153 set words {}
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	154 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	155 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	156 }
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	157 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	158 }
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	159 return $httpHeaders
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	160 }
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	161
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	162 proc ::relmon::common::parseStateFile {stateFile} {
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 f [open $stateFile "r"]
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 open state file \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	168 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	169 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	170 set state [json::json2dict [chan read $f]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	171 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	172 return -options $errorOptions \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	173 "failed to read from state file \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	174 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	175 # the json package does not set an error code
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	176 dict set errorOptions "-errorcode" {RELMON JSON_PARSE_ERROR}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	177 return -options $errorOptions \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	178 "failed to parse state file \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	179 } finally {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	180 close $f
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	181 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	182
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	183 return $state
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	184 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	185
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	186 proc ::relmon::common::parseWatchlist {watchlistFilename} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	187 set Watchlist [dict create]
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	188 set lineno 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	189 set f [open $watchlistFilename "r"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	190 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	191 while {[chan gets $f line] != -1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	192 set fields [textutil::split::splitx [string trim $line] {[\t ]+}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	193 incr lineno
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	194
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	195 if {([llength $fields] == 0) \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	196 ([string index [lindex $fields 0] 0] eq "#")} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	197 # skip empty lines and comments
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	198 continue
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	199 } elseif {[llength $fields] < 3} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	200 # a line consists of a name, base URL and at least one
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	201 # version-matching pattern
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	202 return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	203 "syntax error in \"$watchlistFilename\" line $lineno"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	204 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	205
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	206 set patterns [lassign $fields name baseUrl]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	207
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	208 # validate URL
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	209 if {![::relmon::common::isUrlValid $baseUrl]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	210 return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	211 "syntax error in \"$watchlistFilename\" line $lineno:\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	212 invalid base URL"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	213 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	214
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	215 # process patterns
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	216 set processedPatterns {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	217 set patternIndex 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	218 foreach pattern $patterns {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	219 incr patternIndex
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	220
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	221 # make trailing slashes optional except in the last
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	222 # version-matching pattern
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	223 if {($patternIndex != [llength $patterns]) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	224 ([string index $pattern end] eq "/")} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	225 append pattern {?}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	226 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	227
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	228 # ensure patterns are anchored to the end of the line
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	229 if {[string index $pattern end] ne "$"} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	230 append pattern {$}
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	233 # actually validate the regular expression
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	234 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	235 set reInfo [regexp -about -- $pattern ""]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	236 } on error {errorMsg} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	237 return -code error \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	238 -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	239 "error in \"$watchlistFilename\" line $lineno:\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	240 $errorMsg"
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 lappend processedPatterns $pattern
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	243 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	244 if {[lindex $reInfo 0] < 1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	245 return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	246 "syntax error in \"$watchlistFilename\" line $lineno:\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	247 the last regular expression must contain at least one
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	248 capturing group"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	249 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	250
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	251 dict set Watchlist $name "base_url" $baseUrl
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	252 dict set Watchlist $name "patterns" $processedPatterns
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	253 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	254 } finally {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	255 close $f
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	256 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	257
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	258 return $Watchlist
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	259 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	260
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	261
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	262 namespace eval ::relmon::crawler {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	263 # status returned by crawl
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	264 variable Status
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	265
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	266 # configuration
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	267 variable Config
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	268
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	269 # transfer statistics
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	270 variable Statistics [dict create \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	271 "start_time" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	272 "end_time" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	273 "requests" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	274 "items" 0]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	275
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	276 # ID of a delayed run of ManageTransfers
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	277 variable ManageTransfersId ""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	278
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	279 # queue of pending transfers
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	280 variable Queue
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	281
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	282 # number of active connections per host
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	283 variable HostConnections [dict create]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	284
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	285 # delays before opening a new connection to a host
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	286 variable HostDelays [dict create]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	287
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	288 # active transfers
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	289 variable ActiveTransfers [dict create]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	290
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	291 # number of running or queued transfers of watchlist items
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	292 variable RemainingTransfers [dict create]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	293
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	294 # buffer for tracking the state of unfinished items
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	295 variable StateBuffer [dict create]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	296
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	297 # buffer needed by htmlparse::parse for constructing the preprocessed HTML
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	298 # document
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	299 variable PreprocessedHtmlBuffer
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	300
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	301 # callback when all transfers for an item are finished
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	302 variable OnItemFinishedCmd
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	303
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	304 # logger handle
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	305 variable Log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	306
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	307 namespace export crawl
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	308 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	309
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	310 proc ::relmon::crawler::OnError {message returnOptions} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	311 # internal error, abort
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	312 puts stderr [dict get $returnOptions "-errorinfo"]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	313
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	314 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	315 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	316
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	317 proc ::relmon::crawler::ProcessHtmlElement {tag slash param textBehindTheTag} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	318 variable PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	319
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	320 # copy every "<a>" element into PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	321 if {($slash eq "") && ([string tolower $tag] eq "a")} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	322 append PreprocessedHtmlBuffer "<$tag $param></$tag>"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	323 }
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 return
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
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	328 proc ::relmon::crawler::PreprocessHtml {bodyDataName} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	329 upvar 1 $bodyDataName bodyData
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	330 variable PreprocessedHtmlBuffer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	331
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	332 # preprocess the document with htmlparse by constructing a new document
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	333 # 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	334 # again; this is useful if parsing via tdom fails; however, htmlparse
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	335 # 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	336 # gets easily confused within "<script>" elements and lacks attribute
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	337 # parsing
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	338 set PreprocessedHtmlBuffer "<html><body>"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	339 htmlparse::parse -cmd [namespace code ProcessHtmlElement] $bodyData
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	340 append PreprocessedHtmlBuffer "</body></html>"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	341 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	342
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	343 proc ::relmon::crawler::ExtractUrls {bodyDataName contentType baseUrl
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	344 rePattern} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	345 upvar 1 $bodyDataName bodyData
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	346 set extractedUrls {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	347 set resultUrls [dict create]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	348 # 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	349 switch -- $contentType {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	350 {text/html} -
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	351 {application/xhtml+xml} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	352 # HTML/XHTML
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	353 # if tdom parsing has failed or not found any "<a>" element,
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	354 # preprocess the document with htmlparse and try again
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	355 if {[catch {dom parse -html $bodyData} doc] \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	356 ([set rootElement [$doc documentElement]] eq "") \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	357 ([llength [set aElements \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	358 [$rootElement selectNodes {descendant::a}]]] == 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	359 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	360 set doc [dom parse -html [PreprocessHtml bodyData]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	361 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	362 dict set errorOptions "-errorcode" \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	363 {RELMON TDOM_PARSE_ERROR}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	364 return -options $errorOptions $errorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	365 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	366 set rootElement [$doc documentElement]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	367 set aElements [$rootElement selectNodes {descendant::a}]
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 foreach node $aElements {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	370 set href [$node getAttribute "href" ""]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	371 if {$href ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	372 lappend extractedUrls $href
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	373 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	374 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	375 $doc delete
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	376 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	377 {application/rss+xml} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	378 # RSS 2.0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	379 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	380 set doc [dom parse $bodyData]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	381 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	382 dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	383 return -options $errorOptions $errorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	384 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	385 set rootElement [$doc documentElement]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	386 if {$rootElement ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	387 foreach node [$rootElement selectNodes {descendant::link}] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	388 set linkText [$node text]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	389 if {$linkText ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	390 lappend extractedUrls $linkText
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	391 }
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	394 $doc delete
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 {application/atom+xml} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	397 # Atom 1.0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	398 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	399 set doc [dom parse $bodyData]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	400 } on error {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	401 dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	402 return -options $errorOptions $errorMsg
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 set rootElement [$doc documentElement]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	405 if {$rootElement ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	406 foreach node [$rootElement selectNodes {descendant::link}] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	407 set href [$node getAttribute "href" ""]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	408 if {$href ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	409 lappend extractedUrls $href
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	410 }
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	413 $doc delete
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	414 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	415 {text/plain} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	416 # plain text
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	417 foreach line [split $bodyData "\n"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	418 if {$line ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	419 lappend extractedUrls $line
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 }
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 default {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	424 return -code error \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	425 -errorcode {RELMON UNSUPPORTED_CONTENT_TYPE_ERROR} \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	426 "unsupported content type \"$contentType\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	427 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	428 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	429 foreach url $extractedUrls {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	430 set normalizedUrl [uri::canonicalize [uri::resolve $baseUrl $url]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	431 dict set resultUrls $normalizedUrl \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	432 [expr {[regexp -line -- $rePattern $normalizedUrl] ? 1 : 0}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	433 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	434
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	435 return $resultUrls
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	436 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	437
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	438 proc ::relmon::crawler::StateItemAppendError {name logMsg} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	439 variable StateBuffer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	440
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	441 dict update StateBuffer $name stateItem {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	442 dict lappend stateItem "errors" $logMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	443 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	444
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	445 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	446 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	447
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	448 proc ::relmon::crawler::HandleSuccessfulTransfer {item httpBodyName} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	449 upvar 1 $httpBodyName httpBody
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	450 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	451 variable StateBuffer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	452 variable Queue
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	453 variable RemainingTransfers
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	454 variable Watchlist
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 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	457 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	458 set patternIndex [dict get $item "pattern_index"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	459 set pattern [lindex [dict get $Watchlist $name "patterns"] $patternIndex]
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 ${Log}::info "\"$name\": \"$url\": transfer finished"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	462
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	463 # parse data
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	464 try {
1 cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	465 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	466 $pattern]
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	467 } trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	468 # continue on tdom parsing errors or when receiving documents with an
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	469 # unsupported content type
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	470 set urls [dict create]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	471 set warningMsg "\"$name\": \"$url\": failed to parse data: $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	472 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	473 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	474 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	475
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	476 if {$patternIndex < ([llength \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	477 [dict get $Watchlist $name "patterns"]] - 1)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	478 # if this is not the last, version-matching pattern, queue matched URLs
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	479 dict for {newUrl matched} $urls {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	480 if {$matched} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	481 if {![::relmon::common::isUrlValid $newUrl]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	482 ${Log}::debug "\"$name\": \"$url\": ignoring matched but\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	483 invalid URL \"$newUrl\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	484 continue
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	485 }
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}::debug "\"$name\": \"$url\": queuing \"$newUrl\""
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 dict lappend Queue [::relmon::common::urlGetHost $newUrl] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	490 [dict create "name" $name "url" $newUrl \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	491 "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	492 "content_type" "" "num_redirects" 0 "num_retries" 0]
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	493 dict incr RemainingTransfers $name
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	494 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	495 ${Log}::debug "\"$name\": \"$url\": ignoring \"$newUrl\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	496 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	497 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	498 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	499 # otherwise this branch has finished, try to extract the versions and
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	500 # store them in the buffer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	501 dict for {finalUrl matched} $urls {
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	502 dict set StateBuffer $name "urls" $url $urls
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	503 if {$matched} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	504 regexp -line -- $pattern $finalUrl -> version
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	505 if {$version ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	506 ${Log}::debug "\"$name\": \"$url\": extracted version\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	507 \"$version\" from \"$finalUrl\" found on\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	508 \"$url\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	509 dict set StateBuffer $name "versions" $version $finalUrl
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	510 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	511 ${og}::debug "\"$name\": \"$url\": could not extract a\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	512 version from \"$finalUrl\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	513 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	514 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	515 ${Log}::debug "\"$name\": \"$url\": ignoring \"$finalUrl\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	516 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	517 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	518 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	519
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	520 return
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
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	523 proc ::relmon::crawler::HandleRedirect {item httpCode httpHeaders} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	524 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	525 variable Queue
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	526 variable RemainingTransfers
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	527
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	528 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	529 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	530
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	531 if {![dict exists $httpHeaders "Location"]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	532 # bail out in case of an invalid HTTP response
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	533 set warningMsg "\"$name\": \"$url\": transfer failed: invalid HTTP\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	534 response"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	535 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	536 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	537 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	538 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	539 set location [dict get $httpHeaders "Location"]
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 # sanitize URL from Location header
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	542 if {[uri::isrelative $location]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	543 set redirectUrl [uri::canonicalize [uri::resolve \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	544 $url $location]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	545 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	546 if {![::relmon::common::isUrlValid $location]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	547 # bail out in case of an invalid redirect URL
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	548 set warningMsg "\"$name\": \"$url\": received invalid redirect URL\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	549 \"$location\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	550 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	551 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	552 return
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 set redirectUrl [uri::canonicalize $location]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	555 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	556
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	557 ${Log}::notice "\"$name\": \"$url\": received redirect to \"$redirectUrl\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	558
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	559 # handle up to 10 redirects by re-queuing the target URL
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	560 if {[dict get $item "num_redirects"] < 10} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	561 ${Log}::debug "\"$name\": \"$url\": queuing \"$redirectUrl\" due to\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	562 redirect"
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 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	565 [dict replace $item "url" $redirectUrl "content_type" "" \
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	566 "num_redirects" [expr {[dict get $item "num_redirects"] + 1}] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	567 "num_retries" 0]
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	568 dict incr RemainingTransfers $name
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	569 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	570 set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	571 redirects"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	572 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	573 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	574 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	575
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	576 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	577 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	578
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	579 proc ::relmon::crawler::HandleProtocolError {item httpCode} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	580 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	581 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	582 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	583 set warningMsg "\"$name\": \"$url\": transfer failed: $httpCode"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	584 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	585 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	586 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	587 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	588
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	589 proc ::relmon::crawler::HandleTimeoutReset {item} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	590 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	591 variable Config
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	592 variable Queue
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	593 variable RemainingTransfers
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	594 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	595 set url [dict get $item "url"]
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 # retry by re-queuing the target URL until reaching the limit
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	598 if {[dict get $item "num_retries"] < [dict get $Config "retry_limit"]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	599 ${Log}::warn "\"$name\": \"$url\": connection timed out or was reset,\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	600 retrying"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	601 dict lappend Queue [::relmon::common::urlGetHost $url] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	602 [dict replace $item \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	603 "num_retries" [expr {[dict get $item "num_retries"] + 1}]]
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	604 dict incr RemainingTransfers $name
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	605 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	606 set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	607 retries"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	608 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	609 StateItemAppendError $name $warningMsg
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	612 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	613 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	614
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	615 proc ::relmon::crawler::HandleConnectionError {item errorMsg} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	616 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	617 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	618 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	619 set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	620 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	621 StateItemAppendError $name $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	622 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	623 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	624
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	625 proc ::relmon::crawler::TransferCallbackWrapper {callbackCmd args} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	626 # ensure that exceptions get raised, by default http catches all errors and
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	627 # 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	628 if {[catch {eval $callbackCmd $args} -> errorOptions]} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	629 OnError [dict get $errorOptions "-errorinfo"] $errorOptions
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 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	632 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	633
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	634 proc ::relmon::crawler::ManageTransfers {} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	635 variable Config
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	636 variable ManageTransfersId
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	637 variable Queue
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	638 variable HostConnections
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	639 variable HostDelays
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	640 variable ActiveTransfers
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	641 variable RemainingTransfers
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	642 variable Status
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	643 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	644
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	645 after cancel $ManageTransfersId
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	646
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	647 # try to initiate new transfers
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	648 while {([dict size $ActiveTransfers] <
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	649 [dict get $Config "connection_limit"]) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	650 ([dict size $Queue] > 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	651 # 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	652 # 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	653 set item {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	654 dict for {host items} $Queue {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	655 set now [clock milliseconds]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	656
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	657 if {![dict exists $HostConnections $host]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	658 dict set HostConnections $host 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	659 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	660
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	661 if {![dict exists $HostDelays $host]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	662 dict set HostDelays $host $now
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	665 if {([dict get $HostConnections $host] <
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	666 [dict get $Config "host_connection_limit"]) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	667 ([dict get $HostDelays $host] <= $now)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	668 # pop item from the queue
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	669 set items [lassign $items item]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	670 if {[llength $items] > 0} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	671 dict set Queue $host $items
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	672 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	673 dict unset Queue $host
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	674 }
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 dict incr HostConnections $host
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	677 # set a random delay before the next connection to this host
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	678 # can be made
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	679 dict set HostDelays $host \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	680 [expr {[clock milliseconds] + int((rand() + 0.5) *
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	681 [dict get $Config "host_delay"])}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	682 break
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	685 # 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	686 # queued URLs has been reached and no new transfers may be started
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	687 # at this point
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	688 if {$item eq {}} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	689 break
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	690 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	691 # otherwise start a new transfer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	692 set url [dict get $item "url"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	693 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	694 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	695 set token [http::geturl $url \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	696 -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	697 -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	698 OnTransferProgress}] \
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	699 -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	700 OnTransferFinished}]]
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	701 } on ok {} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	702 dict set ActiveTransfers $token $item
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 ${Log}::info "\"$name\": \"$url\": starting transfer"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	705 } on error {errorMsg} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	706 # an error occured during socket setup, e.g. a DNS lookup failure
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	707 set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	708 ${Log}::warn $warningMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	709 StateItemAppendError $name $warningMsg
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	710 dict incr RemainingTransfers $name -1
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	711 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	712 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	713
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	714 # terminate the event loop if there are no remaining transfers
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	715 if {[::tcl::mathop::+ {*}[dict values $RemainingTransfers]] == 0} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	716 if {([dict size $ActiveTransfers]) > 0 \|\| ([dict size $Queue] > 0)} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	717 ${Log}::error "inconsistent internal state"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	718 set Status 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	719 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	720 set Status 0
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	721 return
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	724 # 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	725 # 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	726 # queue, in this case schedule ManageTransfers again after the smallest of
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	727 # the current per-host delays
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	728 set delay 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	729 if {([dict size $ActiveTransfers] <
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	730 [dict get $Config "connection_limit"]) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	731 ([dict size $Queue] > 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	732 dict for {host items} $Queue {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	733 if {(![dict exists $HostConnections $host] \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	734 ([dict get $HostConnections $host] <
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	735 [dict get $Config "host_connection_limit"])) &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	736 ([dict exists $HostDelays $host] &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	737 ([dict get $HostDelays $host] > $now))} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	738 set hostDelay [expr {[dict get $HostDelays $host] - $now + 1}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	739 if {(($delay == 0) \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	740 ($hostDelay < $delay))} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	741 set delay $hostDelay
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	742 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	743 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	744 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	745 if {$delay > 0} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	746 set ManageTransfersId \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	747 [after $delay [namespace code ManageTransfers]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	748 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	749 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	750
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	751 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	752 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	753
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	754 proc ::relmon::crawler::OnTransferProgress {token total current} {
1 cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	755 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	756 variable ActiveTransfers
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	757 variable Log
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	758
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	759 # 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	760 # 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	761 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	762 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	763 $httpState(meta)]
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	764
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	765 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	766 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	767 [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	768 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	769 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	770 "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	771 "text/plain"}} {
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	772 ${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	773 \"[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	774 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	775 http::reset $token
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	776 }
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	777 }
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 }
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	780
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	781 proc ::relmon::crawler::OnTransferFinished {token} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	782 upvar #0 $token httpState
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	783 variable Config
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	784 variable HostConnections
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	785 variable ActiveTransfers
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	786 variable RemainingTransfers
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	787 variable Statistics
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	788 variable StateBuffer
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	789 variable State
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	790 variable Log
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	791 variable OnItemFinishedCmd
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	792
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	793 set item [dict get $ActiveTransfers $token]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	794 set name [dict get $item "name"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	795 set host [relmon::common::urlGetHost [dict get $item "url"]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	796
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	797 # update list of per-host connections, and number of remaining transfers
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	798 # for this item
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	799 dict unset ActiveTransfers $token
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	800 dict incr HostConnections $host -1
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	801 dict incr RemainingTransfers $name -1
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	802
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	803 switch -- $httpState(status) {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	804 {ok} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	805 # normalize headers
1 cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	806 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	807 $httpState(meta)]
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	808
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	809 # 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	810 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	811 [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	812 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	813 [dict get $httpHeaders "Content-Type"] ";"] 0]]
0 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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	816 # dispatch based on HTTP status code
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	817 set httpCode [http::ncode $token]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	818 switch -glob -- $httpCode {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	819 {30[12378]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	820 HandleRedirect $item $httpCode $httpHeaders
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	821 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	822 {200} {
1 cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	823 HandleSuccessfulTransfer $item httpState(body)
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	824 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	825 default {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	826 HandleProtocolError $item $httpState(http)
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	829 }
1 cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	830 {reset} {
cba4887feb2c Check the content type of documents that are being downloaded Guido Berhoerster <guido+relmon@berhoerster.name> parents: 0 diff changeset	831 # 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	832 }
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	833 {eof} -
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	834 {timeout} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	835 # timeout or connection reset
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	836 HandleTimeoutReset $item
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	837 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	838 {error} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	839 # connection may have failed or been refused
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	840 HandleConnectionError $item [lindex $httpState(error) 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	841 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	842 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	843
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	844 # check if all transfers of this item are finished
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	845 if {[dict get $RemainingTransfers $name] == 0} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	846 eval $OnItemFinishedCmd [list $name [dict get $StateBuffer $name]]
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	847
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	848 dict unset StateBuffer $name
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 ${Log}::notice "progress: [dict size $StateBuffer]/[dict get \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	851 $Statistics "items"] items left"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	852 }
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 http::cleanup $token
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 ManageTransfers
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	857
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	858 return
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	859 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	860
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	861 # control certificate verification and log errors during TLS handshake
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	862 proc ::relmon::crawler::OnTlsHandshake {type args} {
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	863 variable Config
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	864 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	865
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	866 switch -- ${type} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	867 {error} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	868 lassign $args {} tlsErrorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	869 ${Log}::error "TLS connection error: $tlsErrorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	870 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	871 {verify} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	872 lassign $args {} {} {} status tlsErrorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	873 array set cert [lindex $args 2]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	874 if {$status == 0} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	875 if {[dict get $Config "ca_dir"] eq ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	876 # do not verify certificates is ca-dir was not set
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	877 return 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	878 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	879 set errorMsg "$tlsErrorMsg\nCertificate details:"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	880 foreach {key description} {"serial" "Serial Number"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	881 "issuer" "Issuer" "notBefore" "Not Valid Before"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	882 "notAfter" "Not Valid After" "subject" "Subject"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	883 "sha1_hash" "SHA1 Hash"} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	884 append errorMsg "\n$description: $cert($key)"
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 ${Log}::error "TLS connection error: $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	887 return 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	888 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	889 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	890 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	891 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	892 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	893
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	894 proc ::relmon::crawler::crawl {config watchlist log onItemFinishedCmd} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	895 variable Config $config
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	896 variable Watchlist $watchlist
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	897 variable Queue
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	898 variable Statistics
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	899 variable Log $log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	900 variable OnItemFinishedCmd $onItemFinishedCmd
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	901 variable Status
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	902 variable RemainingTransfers
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	903 variable StateBuffer
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	904
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	905 # initialize queue and state buffer from the watchlist
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	906 set Queue [dict create]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	907 dict for {name watchlistItem} $Watchlist {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	908 dict lappend Queue [::relmon::common::urlGetHost \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	909 [dict get $watchlistItem "base_url"]] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	910 [dict create \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	911 "name" $name \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	912 "url" [dict get $watchlistItem "base_url"] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	913 "pattern_index" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	914 "content_type" "" \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	915 "num_redirects" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	916 "num_retries" 0]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	917 dict set RemainingTransfers $name 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	918 dict incr Statistics "items"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	919 dict set StateBuffer $name [dict create "versions" [dict create] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	920 "errors" [list] "urls" [dict create]]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	921 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	922
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	923 # configure http and tls
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	924 http::register https 443 [list tls::socket \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	925 -cadir [dict get $Config "ca_dir"] -request 1 -require 1 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	926 -command [namespace code OnTlsHandshake] -ssl2 0 -ssl3 1 -tls1 1]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	927 http::config -useragent "Mozilla/5.0 (Windows NT 6.1; rv:16.0)\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	928 Gecko/20100101 Firefox/16.0 relmon/$relmon::VERSION"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	929
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	930 # handle errors while in the event loop
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	931 interp bgerror {} [namespace code OnError]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	932
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	933 dict set Statistics "start_time" [clock milliseconds]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	934
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	935 # enter the main loop
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	936 after idle [namespace code ManageTransfers]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	937 vwait [namespace which -variable Status]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	938
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	939 # display statistics
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	940 dict set Statistics "end_time" [clock milliseconds]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	941 ${Log}::notice "items checked: [dict get $Statistics "items"]"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	942 ${Log}::notice "time elapsed: [expr {([dict get $Statistics "end_time"] -
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	943 [dict get $Statistics "start_time"]) / 1000}]s"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	944
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	945 return $Status
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	946 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	947
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	948
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	949 namespace eval ::relmon::update {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	950 # commandline option help text
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	951 variable usage "usage: relmon update \[-dev\] \[-c max_connections\]\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	952 \[-C ca_dir\] \[-D host_delay\]\n\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	953 \ \[-H max_connections_per_host\]\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	954 \[-i item_list\]\n\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	955 \ \[-l logfile\] \[-r retries\]\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	956 \[-t before_seconds\]\n\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	957 \ \[-T timeout_seconds\] watchlist statefile"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	958
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	959 # configuration options
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	960 variable Config [dict create \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	961 "log_file" "" \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	962 "log_level" "notice" \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	963 "history_limit" 20 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	964 "connection_limit" 16 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	965 "host_connection_limit" 4 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	966 "transfer_time_limit" 60000 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	967 "retry_limit" 3 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	968 "host_delay" 500 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	969 "host_delays" [dict create] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	970 "timestamp_filter" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	971 "error_filter" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	972 "item_filter" {} \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	973 "ca_dir" "" \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	974 "state_file" "" \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	975 "watchlist_file" ""]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	976
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	977 # watchlist
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	978 variable Watchlist
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	979
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	980 # logger handle
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	981 variable Log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	982
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	983 # logfile handle
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	984 variable Lf
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	985 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	986
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	987 proc ::relmon::update::OnItemFinished {name stateItem} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	988 variable State
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	989 variable Log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	990 variable Config
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	991
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	992 set timestamp [clock milliseconds]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	993
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	994 # create httpState item if it does not exist yet
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	995 if {![dict exists $State $name]} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	996 dict set State $name [dict create "versions" [dict create] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	997 "history" [list] "timestamp" 0 "errors" [list]]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	998 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	999
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1000 # if there are no versions, log an error message since something must
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1001 # be wrong
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1002 if {[llength [dict get $stateItem "versions"]] == 0} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1003 set warningMsg "\"$name\": no versions found"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1004 ${Log}::warn $warningMsg
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1005 dict lappend stateItem "errors" $warningMsg
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1006 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1007
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1008 # update httpState item
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1009 dict set State $name "errors" [dict get $stateItem "errors"]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1010 dict set State $name "timestamp" $timestamp
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1011 if {[llength [dict get $stateItem "errors"]] == 0} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1012 # expire old history entries
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1013 set history [lrange [dict get $State $name "history"] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1014 [expr {[llength [dict get $State $name "history"]] -
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1015 [dict get $Config "history_limit"] + 1}] end]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1016
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1017 # add currently latest available version to history if it is either
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1018 # newer than the previous one or if the previous one is no longer
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1019 # available (e.g. if it has been removed or the watchlist pattern
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1020 # has been changed)
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1021 set prevLatestVersion [lindex $history end 0]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1022 set curLatestVersion [lindex \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1023 [lsort -command ::relmon::common::cmpVersion \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1024 [dict keys [dict get $stateItem "versions"]]] end]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1025 if {([::relmon::common::cmpVersion $curLatestVersion \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1026 $prevLatestVersion] > 0) \|\|
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1027 ![dict exists $stateItem "versions" $prevLatestVersion]} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1028 lappend history [list $curLatestVersion $timestamp]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1029 dict set State $name "history" $history
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1030 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1031 dict set State $name "versions" [dict get $stateItem "versions"]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1032 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1033 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1034
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1035 proc ::relmon::update::CleanupBeforeExit {commandString op} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1036 variable Lf
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1037
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1038 # close logfile
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1039 if {($Lf ne "") && ($Lf ni {stdin stderr})} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1040 close $Lf
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1041 set Lf ""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1042 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1043
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1044 return
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1045 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1046
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1047 proc ::relmon::update::main {args} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1048 variable Config
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1049 variable usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1050 variable State
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1051 variable Log
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1052 variable Lf ""
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 # parse commandline
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1055 while {[set GetoptRet [cmdline::getopt args \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1056 {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	1057 OptArg OptVal]] == 1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1058 switch -glob -- $OptArg {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1059 {c} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1060 if {![string is digit -strict $OptVal] \|\| ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1061 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1062 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1063 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1064 dict set Config "host_connection_limit" $OptVal
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1065 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1066 {C} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1067 if {![file isdirectory $OptVal]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1068 puts stderr "directory \"$OptVal\" is not a directory"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1069 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1070 } elseif {![file readable $OptVal] \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1071 ![file executable $OptVal]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1072 puts stderr "directory \"$OptVal\" is not readable"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1073 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1074 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1075 dict set Config "ca_dir" $OptVal
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1076 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1077 {d} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1078 dict set Config "log_level" "debug"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1079 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1080 {D} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1081 if {![string is digit -strict $OptVal] \|\| ($OptVal < 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1082 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1083 exit 1
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 dict set Config "host_delay" [expr {$OptVal * 1000}]
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 {e} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1088 dict set Config "error_filter" 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1089 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1090 {H} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1091 if {![string is digit -strict $OptVal] \|\| ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1092 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1093 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1094 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1095 dict set Config "connection_limit" $OptVal
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1096 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1097 {i} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1098 foreach item [split $OptVal " "] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1099 set item [string trim $item]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1100 if {$item ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1101 dict lappend Config "item_filter" $item
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1102 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1103 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1104 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1105 {l} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1106 dict set Config "log_file" $OptVal
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1107 set LogDir [file dirname $OptVal]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1108 if {![file writable $LogDir] \|\| ![file executable $LogDir]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1109 puts stderr "directory \"$LogDir\" is not writable"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1110 exit 1
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1113 {r} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1114 if {![string is digit -strict $OptVal] \|\| ($OptVal < 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1115 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1116 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1117 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1118 dict set Config "retry_limit" $OptVal
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1119 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1120 {t} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1121 if {![string is digit -strict $OptVal] \|\| ($OptVal < 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1122 puts stderr "invalid value passed to \"-$OptArg\""
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 dict set Config "timestamp_filter" [expr {$OptVal * 1000}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1126 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1127 {T} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1128 if {![string is digit -strict $OptVal] \|\| ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1129 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1130 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1131 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1132 dict set Config "transfer_time_limit" [expr {$OptVal * 1000}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1133 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1134 {v} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1135 if {[dict get $Config "log_level"] ne "debug"} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1136 dict set Config "log_level" "info"
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1139 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1140 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1141 set argc [llength $args]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1142 if {$GetoptRet == -1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1143 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1144 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1145 exit 1
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 {$argc != 2} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1148 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1149 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1150 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1151 dict set Config "watchlist_file" [lindex $args 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1152 if {![file readable [dict get $Config "watchlist_file"]]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1153 puts stderr "watchlist file \"[dict get $Config "watchlist_file"]\"\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1154 could not be read"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1155 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1156 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1157 set stateFile [lindex $args 1]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1158 dict set Config "state_file" $stateFile
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1159 set StateDir [file dirname $stateFile]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1160 if {![file writable $StateDir]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1161 puts stderr "directory \"$StateDir\" is not writable"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1162
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1163 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1164 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1165
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1166 # install exit handler for closing the logfile, open the logfile and
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1167 # initialize logger
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1168 trace add execution exit enter CleanupBeforeExit
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1169 if {[dict get $Config "log_file"] ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1170 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1171 set Lf [open [dict get $Config "log_file"] "w"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1172 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1173 puts stderr "failed to open logfile\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1174 \"[dict get $Config "log_file"]\": $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1175 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1176 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1177 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1178 set Lf stderr
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1179 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1180 set Log [logger::init global]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1181 if {[dict get $Config "log_level"] eq "debug"} {
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1182 set logFormat $relmon::LogFormatDebug
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1183 } else {
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1184 set logFormat $relmon::LogFormatDefault
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1185 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1186 logger::utils::applyAppender -appender fileAppend -appenderArgs \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1187 [list -outputChannel $Lf -conversionPattern $logFormat] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1188 -serviceCmd $Log
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 # set default logging level
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1191 ${Log}::setlevel [dict get $Config "log_level"]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1192
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1193 ${Log}::notice "relmon.tcl starting up"
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 # parse the watchlist
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1196 try {
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1197 set Watchlist [relmon::common::parseWatchlist \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1198 [dict get $Config "watchlist_file"]]
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1199 } trap {POSIX} {errorMsg errorOptions} - \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1200 trap {RELMON} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1201 ${Log}::error $errorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1202 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1203 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1204
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1205 # read the state file
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1206 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1207 set State [::relmon::common::parseStateFile $stateFile]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1208 } trap {POSIX ENOENT} {errorMsg} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1209 ${Log}::debug "state file \"$stateFile\" does not exist"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1210 set State [dict create]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1211 } trap {POSIX} {errorMsg} - \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1212 trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1213 ${Log}::error $errorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1214 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1215 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1216
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1217 # apply filters specified on the command line to watchlist items
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1218 set currentTime [clock milliseconds]
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1219 dict for {name watchlistItem} $Watchlist {
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1220 if {(([llength [dict get $Config "item_filter"]] > 0) &&
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1221 ($name ni [dict get $Config "item_filter"])) \|\|
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1222 ([dict get $Config "error_filter"] &&
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1223 [dict exists $State $name "errors"] &&
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1224 ([llength [dict get $State $name "errors"]] == 0)) \|\|
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1225 ([dict exists $State $name "timestamp"] &&
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1226 ([dict get $State $name "timestamp"] > $currentTime -
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1227 [dict get $Config "timestamp_filter"]))} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1228 dict unset Watchlist $name
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1229 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1230 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1231
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1232 set ExitStatus [relmon::crawler::crawl $Config $Watchlist $Log \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1233 [namespace code OnItemFinished]]
0 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 # serialize the new state
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1236 set JsonStateItems {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1237 dict for {item data} $State {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1238 set versions {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1239 dict for {version url} [dict get $data "versions"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1240 lappend versions $version [json::write string $url]
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 set history {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1243 foreach historyItem [dict get $data "history"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1244 lassign $historyItem version timestamp
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1245 lappend history [json::write array [json::write string $version] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1246 $timestamp]
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 set errors {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1249 foreach errorItem [dict get $data "errors"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1250 lappend errors [json::write string $errorItem]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1251 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1252 lappend JsonStateItems $item [json::write object \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1253 "versions" [json::write object {*}$versions] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1254 "history" [json::write array {*}$history] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1255 "timestamp" [dict get $data "timestamp"] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1256 "errors" [json::write array {*}$errors]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1257 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1258 set JsonState [json::write object {*}$JsonStateItems]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1259
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1260 # try to preserve permissions and ownership
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1261 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1262 set stateFileAttributes [file attributes $stateFile]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1263 } trap {POSIX ENOENT} {} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1264 set stateFileAttributes {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1265 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1266 ${Log}::error "failed to stat \"$stateFile\": $errorMsg"
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 # write the new state to a temporary file
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1269 set tmpFile "$stateFile.[pid].tmp"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1270 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1271 set f [open $tmpFile {RDWR CREAT EXCL TRUNC} 0600]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1272 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1273 ${Log}::error "failed to open \"$tmpFile\": $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 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1278 chan puts -nonewline $f $JsonState
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1279 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1280 catch {file delete $tmpFile}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1281
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1282 ${Log}::error "failed to write to \"$tmpFile\": $errorMsg"
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 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1285 } finally {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1286 close $f
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1287 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1288 # make a backup of the previous state file
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1289 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1290 file copy -force $stateFile "$stateFile~"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1291 } trap {POSIX ENOENT} {} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1292 # ignore non-existing file
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1293 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1294 ${Log}::error "failed to create a backup of \"$statFile\":\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1295 $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1296 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1297 # rename the temporary file to the state file name
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1298 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1299 file rename -force $tmpFile $stateFile
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1300 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1301 catch {file delete $tmpFile}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1302
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1303 ${Log}::error "failed to rename \"$tmpFile\" to \"$stateFile\":\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1304 $errorMsg"
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 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1307 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1308 # restore ownership and permissions
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1309 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1310 file attributes $stateFile {*}$stateFileAttributes
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1311 } trap {POSIX} {errorMsg errorOptions} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1312 ${Log}::error "failed to set permissions and ownership on\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1313 \"$stateFile\": $errorMsg"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1314
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1315 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1316 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1317
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1318 # clean up
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1319 ${Log}::delete
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1320
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1321 exit $ExitStatus
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1324
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1325 namespace eval ::relmon::show {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1326 # commandline option help text
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1327 variable usage "usage: relmon show statefile name..."
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1328 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1329
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1330 proc ::relmon::show::GetItem {stateName name} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1331 upvar 1 $stateName state
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1332 set item [dict get $state $name]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1333
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1334 # format state data as plain-text
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1335 set output ""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1336 append output "Name: $name\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1337 append output "Latest Version:\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1338 [lindex [lindex [dict get $item "history"] end] 0]\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1339 append output "Refreshed: [clock format \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1340 [expr {[dict get $item "timestamp"] / 1000}] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1341 -format {%Y-%m-%dT%H:%M:%S%z}]\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1342 append output "Versions:\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1343 dict for {version url} [dict get $item "versions"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1344 append output "\t$version $url\n"
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 append output "Errors:\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1347 if {[dict get $item "errors"] eq ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1348 append output "\tNone\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1349 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1350 foreach errorMsg [dict get $item "errors"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1351 append output "\t[string map {\n \n\t} [string trim $errorMsg]]\n"
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 append output "History:\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1355 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1356 append output "\t[lindex $historyItem 0] [clock format \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1357 [expr {[lindex $historyItem 1] / 1000}] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1358 -format {%Y-%m-%dT%H:%M:%S%z}]\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1359 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1360 return $output
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1363 proc ::relmon::show::main {args} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1364 variable usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1365
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1366 # parse commandline
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1367 if {[cmdline::getopt args {} OptArg OptVal] == -1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1368 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1369 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1370 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1371 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1372 if {[llength $args] < 2} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1373 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1374 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1375 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1376 set stateFile [lindex $args 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1377 set names [lrange $args 1 end]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1378
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1379 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1380 set state [::relmon::common::parseStateFile $stateFile]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1381 } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1382 puts stderr $errorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1383 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1384 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1385
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1386 # show each item
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1387 foreach name $names {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1388 puts -nonewline [GetItem state $name]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1389 }
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 exit 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1392 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1393
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1394
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1395 namespace eval ::relmon::list {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1396 # commandline option help text
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1397 variable usage "usage: relmon list \[-H\] \[-f html\|parseable\|text\]\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1398 \[-F url\]\n\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1399 \ \[-n number_items\] statefile\n\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1400 \ relmon list -f atom -F url \[-n number_items\] statefile"
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 # configuration options
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1403 variable Config [dict create \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1404 "format" "text" \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1405 "show_history" 0 \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1406 "history_limit" 100 \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1407 "feed_url" ""]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1408 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1409
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1410 proc ::relmon::list::FormatText {stateName includeHistory historyLimit} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1411 upvar 1 $stateName state
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1412 set output ""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1413 append output [format "%-35s %-15s %-24s %-3s\n" "Project" "Version" \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1414 "Refreshed" "St."]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1415 append output [string repeat "-" 80]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1416 append output "\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1417
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1418 set history {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1419 dict for {name item} $state {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1420 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1421 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1422 [lindex $historyItem 0]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1423 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1424 set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1425 set timestamp [clock format [expr {[dict get $item "timestamp"] /
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1426 1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1427 set status [expr {[llength [dict get $item "errors"]] > 0 ? "E" : ""}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1428 append output [format "%-35s %15s %-24s %-1s\n" $name $latestVersion \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1429 $timestamp $status]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1430 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1431 if {$includeHistory} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1432 append output "\nHistory\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1433 append output [string repeat "-" 80]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1434 append output "\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1435 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1436 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1437 append output [format "%-24s %-35s %15s\n" \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1438 [clock format [expr {[lindex $historyItem 0] / 1000}] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1439 -format {%Y-%m-%dT%H:%M:%S%z}] [lindex $historyItem 1] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1440 [lindex $historyItem 2]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1441 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1442 }
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 return $output
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1445 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1446
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1447 proc ::relmon::list::FormatParseable {stateName includeHistory historyLimit} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1448 upvar 1 $stateName state
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1449 set output ""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1450 set history {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1451 dict for {name item} $state {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1452 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1453 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1454 [lindex $historyItem 0]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1455 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1456 set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1457 if {$latestVersion eq ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1458 set latestVersion -
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1459 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1460 set timestamp [clock format [expr {[dict get $item "timestamp"] /
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1461 1000}] -timezone :UTC -format {%Y-%m-%dT%H:%M:%SZ}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1462 set status [expr {[llength [dict get $item "errors"]] > 0 ? "ERROR" :
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1463 "OK"}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1464 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	1465 $timestamp $status]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1466 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1467 if {$includeHistory} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1468 append output "\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1469 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1470 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1471 append output [format "%s\t%s\t%s\n" [clock format \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1472 [expr {[lindex $historyItem 0] / 1000}] -timezone :UTC \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1473 -format {%Y-%m-%dT%H:%M:%SZ}] [lindex $historyItem 1] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1474 [lindex $historyItem 2]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1475 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1476 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1477 return $output
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1478 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1479
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1480 proc ::relmon::list::FormatHtml {stateName includeHistory historyLimit
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1481 feedUrl} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1482 upvar 1 $stateName state
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 set output "<html>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1485 append output "<head>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1486 append output "<title>Current Releases</title>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1487 if {$feedUrl ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1488 append output "<link type=\"application/atom+xml\" rel=\"alternate\"\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1489 title=\"Release History\"\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1490 href=\"[html::html_entities $feedUrl]\"/>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1491 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1492 append output "</head>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1493 append output "<body>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1494 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	1495 \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	1496 set history {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1497 dict for {name item} $state {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1498 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1499 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1500 [lindex $historyItem 0]]
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 set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1503 set timestamp [clock format [expr {[dict get $item "timestamp"] /
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1504 1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1505 set status [expr {[llength [dict get $item "errors"]] > 0 ? "Error" :
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1506 "OK"}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1507
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1508 append output "<tr>\n<td>[html::html_entities $name]</td>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1509 if {$latestVersion ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1510 if {[dict exists $item "versions" $latestVersion]} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1511 set url [dict get $item "versions" $latestVersion]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1512 append output "<td><a\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1513 href=\"[html::html_entities $url]\"\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1514 title=\"[html::html_entities\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1515 "$name $latestVersion"]\">[html::html_entities \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1516 $latestVersion]</a></td>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1517 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1518 append output "<td>[html::html_entities \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1519 $latestVersion]</td>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1520 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1521 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1522 append output "<td></td>\n"
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 append output "<td>$timestamp</td>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1525 append output "<td>[html::html_entities $status]</td>\n</tr>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1526 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1527 append output "</table>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1528
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1529 if {$includeHistory} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1530 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1531 append output "<h1>Release History</h1>\n<table>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1532 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	1533 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1534 set timestamp [clock format [expr {[lindex $historyItem 0] /
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1535 1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1536 set name [lindex $historyItem 1]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1537 set version [lindex $historyItem 2]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1538 append output "<tr>\n<td>$timestamp</td>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1539 append output "<td>[html::html_entities $name]</td>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1540 append output "<td>[html::html_entities $version]</td></tr>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1541 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1542 append output "</table>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1543 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1544
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1545 append output "</body>\n</html>\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 return $output
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1548 }
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 proc ::relmon::list::FormatAtom {stateName historyLimit feedUrl} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1551 upvar 1 $stateName state
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1552 set host [::relmon::common::urlGetHost $feedUrl]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1553 set output "<?xml version=\"1.0\" encoding=\"utf-8\"?>\
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1554 \n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1555 append output "<author><name>relmon</name></author>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1556 append output "<title>Release History</title>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1557 append output "<id>[html::html_entities $feedUrl]</id>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1558 set history {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1559 dict for {name item} $state {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1560 foreach historyItem [dict get $item "history"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1561 lappend history [list [lindex $historyItem 1] $name \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1562 [lindex $historyItem 0]]
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1565 set history [lsort -decreasing -integer -index 0 $history]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1566 set updated [lindex [lindex $history end] 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1567 if {$updated eq ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1568 set updated [clock seconds]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1569 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1570 append output "<updated>[clock format $updated \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1571 -format {%Y-%m-%dT%H:%M:%S%z}]</updated>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1572 foreach historyItem [lrange $history 0 $historyLimit] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1573 set name [lindex $historyItem 1]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1574 set version [lindex $historyItem 2]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1575 set timestamp [clock format [expr {[lindex $historyItem 0] / 1000}] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1576 -format {%Y-%m-%dT%H:%M:%S%z}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1577 set id "tag:$host,[clock format [lindex $historyItem 0] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1578 -format {%Y-%m-%d}]:[uri::urn::quote $name-$version]"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1579 append output "<entry>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1580 append output "<id>[html::html_entities $id]</id>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1581 append output "<updated>$timestamp</updated>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1582 append output "<title>[html::html_entities "$name $version"]</title>"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1583 append output "<content>[html::html_entities \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1584 "$name $version"]</content>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1585 append output "</entry>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1586 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1587 append output "</feed>\n"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1588 return $output
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1589 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1590
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1591 proc ::relmon::list::main {args} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1592 variable usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1593 variable Config
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1594
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1595 # parse commandline
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1596 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	1597 OptVal]] == 1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1598 switch -glob -- $OptArg {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1599 {f} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1600 if {$OptVal ni {atom html parseable text}} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1601 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1602 exit 1
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 dict set Config "format" $OptVal
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1605 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1606 {F} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1607 if {[catch {dict create {*}[uri::split $OptVal]} UrlParts] \|\|
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1608 ([dict get $UrlParts "host"] eq "")} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1609 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1610 exit 1
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 dict set Config "feed_url" $OptVal
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1613 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1614 {H} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1615 dict set Config "show_history" 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1616 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1617 {n} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1618 if {![string is digit -strict $OptVal] \|\| ($OptVal <= 0)} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1619 puts stderr "invalid value passed to \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1620 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1621 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1622 dict set Config "history_limit" [expr {$OptVal - 1}]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1623 }
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 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1626 set argc [llength $args]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1627 if {$GetoptRet == -1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1628 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1629 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1630 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1631 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1632 if {$argc != 1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1633 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1634 exit 1
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 if {([dict get $Config "format"] eq "atom") &&
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1637 ([dict get $Config "feed_url"] eq "")} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1638 puts stderr "mandatory \"-F\" option is missing"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1639 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1640 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1641 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1642 set StateFile [lindex $args 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1643
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1644 # read the state file
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1645 try {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1646 set State [::relmon::common::parseStateFile $StateFile]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1647 } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1648 puts stderr $errorMsg
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1649 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1650 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1651
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1652 # call formatter
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1653 switch -- [dict get $Config "format"] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1654 {atom} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1655 puts -nonewline [FormatAtom State \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1656 [dict get $Config "history_limit"] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1657 [dict get $Config "feed_url"]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1658 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1659 {html} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1660 puts -nonewline [FormatHtml State \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1661 [dict get $Config "show_history"] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1662 [dict get $Config "history_limit"] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1663 [dict get $Config "feed_url"]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1664 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1665 {parseable} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1666 puts -nonewline [FormatParseable State \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1667 [dict get $Config "show_history"] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1668 [dict get $Config "history_limit"]]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1669 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1670 {default} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1671 puts -nonewline [FormatText State \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1672 [dict get $Config "show_history"] \
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1673 [dict get $Config "history_limit"]]
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1677 exit 0
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
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1681 namespace eval ::relmon::help {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1682 # commandline option help text
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1683 variable usage "usage: relmon help \[subcommand\]"
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1684 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1685
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1686 proc ::relmon::help::main {args} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1687 variable usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1688
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1689 # parse commandline
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1690 if {[cmdline::getopt args {} OptArg OptVal] == -1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1691 puts stderr "unknown command line option \"-$OptArg\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1692 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1693 exit 1
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 set argc [llength $args]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1696 if {$argc > 1} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1697 puts stderr $usage
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 set subCommand [lindex $args 0]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1701 if {$subCommand ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1702 if {[info procs ::relmon::${subCommand}::main] ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1703 puts stderr [set ::relmon::${subCommand}::usage]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1704 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1705 puts stderr "unknown subcommand \"$subCommand\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1706 puts stderr $usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1707 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1708 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1709 } else {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1710 foreach subCommandNs [namespace children ::relmon] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1711 if {[info procs ${subCommandNs}::main] ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1712 puts stderr [set ${subCommandNs}::usage]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1713 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1714 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1715 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1716 exit 0
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1717 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1718
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1719
5 86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1720 namespace eval ::relmon::discover {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1721 # commandline option help text
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1722 variable usage "usage: relmon discover \[-d\] \[-c max_connections\]\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1723 \[-C ca_dir\] \[-D host_delay\]\n\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1724 \ \[-H max_connections_per_host\]\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1725 \[-r retries\]\n\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1726 \ \[-t before_seconds\]\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1727 \[-T timeout_seconds\] base_url\n\
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1728 \ \[pattern...\]"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1729
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1730 # configuration options
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1731 variable Config [dict create \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1732 "log_file" "" \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1733 "log_level" "info" \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1734 "connection_limit" 16 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1735 "host_connection_limit" 4 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1736 "transfer_time_limit" 60000 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1737 "retry_limit" 3 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1738 "host_delay" 500 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1739 "host_delays" [dict create] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1740 "ca_dir" ""]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1741
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1742 # transfer statistics
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1743 variable Statistics [dict create \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1744 "start_time" [clock milliseconds] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1745 "end_time" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1746 "requests" 0 \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1747 "items" 0]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1748
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1749 # watchlist
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1750 variable Queue [dict create]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1751
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1752 # logger handle
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1753 variable Log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1754 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1755
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1756 proc ::relmon::discover::OnItemFinished {name stateItem} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1757 variable Log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1758
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1759 dict for {url urls} [dict get $stateItem "urls"] {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1760 dict for {linkUrl matched} $urls {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1761 if {$matched} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1762 puts "\"$url\": found matching URL \"$linkUrl\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1763 } else {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1764 puts "\"$url\": found non-matching URL \"$linkUrl\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1765 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1766 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1767 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1768 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1769
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1770 proc ::relmon::discover::main {args} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1771 variable Config
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1772 variable usage
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1773 variable Log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1774 variable Queue
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1775
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1776 # parse commandline
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1777 while {[set GetoptRet [cmdline::getopt args \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1778 {c.arg C.arg d D.arg h H.arg r.arg t.arg T.arg ?} \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1779 OptArg OptVal]] == 1} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1780 switch -glob -- $OptArg {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1781 {c} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1782 if {![string is digit -strict $OptVal] \|\| ($OptVal <= 0)} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1783 puts stderr "invalid value passed to \"-$OptArg\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1784 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1785 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1786 dict set Config "host_connection_limit" $OptVal
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1787 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1788 {C} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1789 if {![file isdirectory $OptVal]} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1790 puts stderr "directory \"$OptVal\" is not a directory"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1791 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1792 } elseif {![file readable $OptVal] \|\|
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1793 ![file executable $OptVal]} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1794 puts stderr "directory \"$OptVal\" is not readable"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1795 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1796 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1797 dict set Config "ca_dir" $OptVal
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1798 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1799 {d} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1800 dict set Config "log_level" "debug"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1801 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1802 {D} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1803 if {![string is digit -strict $OptVal] \|\| ($OptVal < 0)} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1804 puts stderr "invalid value passed to \"-$OptArg\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1805 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1806 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1807 dict set Config "host_delay" $OptVal
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1808 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1809 {[h?]} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1810 puts stderr $usage
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1811 exit 0
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1812 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1813 {H} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1814 if {![string is digit -strict $OptVal] \|\| ($OptVal <= 0)} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1815 puts stderr "invalid value passed to \"-$OptArg\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1816 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1817 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1818 dict set Config "connection_limit" $OptVal
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1819 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1820 {r} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1821 if {![string is digit -strict $OptVal] \|\| ($OptVal < 0)} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1822 puts stderr "invalid value passed to \"-$OptArg\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1823 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1824 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1825 dict set Config "retry_limit" $OptVal
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1826 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1827 {t} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1828 if {![string is digit -strict $OptVal] \|\| ($OptVal < 0)} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1829 puts stderr "invalid value passed to \"-$OptArg\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1830 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1831 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1832 dict set Config "timestamp_filter" [expr {$OptVal * 1000}]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1833 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1834 {T} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1835 if {![string is digit -strict $OptVal] \|\| ($OptVal <= 0)} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1836 puts stderr "invalid value passed to \"-$OptArg\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1837 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1838 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1839 dict set Config "transfer_time_limit" [expr {$OptVal * 1000}]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1840 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1841 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1842 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1843 set argc [llength $args]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1844 if {$GetoptRet == -1} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1845 puts stderr "unknown command line option \"-$OptArg\""
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1846 puts stderr $usage
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1847 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1848 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1849 if {$argc < 1} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1850 puts stderr $usage
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1851 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1852 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1853
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1854 set patterns [lassign $args baseUrl]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1855
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1856 # validate URL
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1857 if {![::relmon::common::isUrlValid $baseUrl]} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1858 puts stderr "invalid base URL"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1859 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1860 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1861
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1862 # process patterns
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1863 set processedPatterns {}
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1864 set reInfo {}
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1865 set patternIndex 0
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1866 foreach pattern $patterns {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1867 incr patternIndex
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1868
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1869 # make trailing slashes optional
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1870 if {($patternIndex != [llength $patterns]) &&
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1871 ([string index $pattern end] eq "/")} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1872 append pattern {?}
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1873 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1874
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1875 # ensure patterns are anchored to the end of the line
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1876 if {[string index $pattern end] ne "$"} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1877 append pattern {$}
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1878 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1879
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1880 # actually validate the regular expression
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1881 try {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1882 set reInfo [regexp -about -- $pattern ""]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1883 } on error {errorMsg} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1884 puts stderr $errorMsg
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1885 exit 1
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1886 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1887 lappend processedPatterns $pattern
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1888 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1889 # add a dummy pattern "()" if the last pattern is does not contain a
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1890 # capturing group, this will match every link and capture an empty string
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1891 if {[lindex $reInfo 0] < 1} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1892 lappend processedPatterns {()}
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1893 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1894
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1895 # construct a watchlist from the command line arguments
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1896 set watchlist [dict create "new project" [dict create "base_url" $baseUrl \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1897 "patterns" $processedPatterns]]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1898
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1899 set Log [logger::init global]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1900 if {[dict get $Config "log_level"] eq "debug"} {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1901 set logFormat $relmon::LogFormatDebug
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1902 } else {
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1903 set logFormat $relmon::LogFormatDefault
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1904 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1905 logger::utils::applyAppender -appender fileAppend -appenderArgs \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1906 [list -outputChannel stderr -conversionPattern $logFormat] \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1907 -serviceCmd $Log
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1908
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1909 # set default logging level
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1910 ${Log}::setlevel [dict get $Config "log_level"]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1911
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1912 ${Log}::notice "relmon.tcl starting up"
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1913
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1914 set ExitStatus [relmon::crawler::crawl $Config $watchlist $Log \
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1915 [namespace code OnItemFinished]]
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1916
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1917 exit $ExitStatus
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1918 }
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1919
86a0c5d11f05 Add discover subcommand Guido Berhoerster <guido+relmon@berhoerster.name> parents: 3 diff changeset	1920
0 8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1921 proc ::relmon::main {args} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1922 variable usage
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1923 set subArgs [lassign $args subCommand]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1924
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1925 # generate list of subcommands
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1926 set subCommands {}
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1927 foreach subCommandNs [namespace children ::relmon] {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1928 if {[info procs ${subCommandNs}::main] ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1929 lappend subCommands [namespace tail $subCommandNs]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1930 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1931 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1932 if {$subCommand ni $subCommands} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1933 if {$subCommand ne ""} {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1934 puts stderr "unknown subcommand \"$subCommand\""
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1935 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1936 foreach command $subCommands {
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1937 puts stderr [set relmon::${command}::usage]
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1938 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1939 exit 1
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1940 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1941
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1942 # dispatch subcommand
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1943 relmon::${subCommand}::main {*}$subArgs
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1944 }
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1945
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1946
8c5330f6e9e4 Initial revision Guido Berhoerster <guido+relmon@berhoerster.name> parents: diff changeset	1947 relmon::main {*}$argv

Mercurial > projects > relmon

annotate relmon.tcl.in @ 6:45fe94dbc236