projects/relmon

changeset 3:6d87242c537e

Add Makefile

Use make to allow changing the tclsh path and for easy installation.
author Guido Berhoerster <guido+relmon@berhoerster.name>
date Mon Oct 20 19:31:20 2014 +0200 (2014-10-20)
parents 0203fffb4d74
children f28486666a4f
files Makefile README relmon.tcl relmon.tcl.in
line diff
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/Makefile	Mon Oct 20 19:31:20 2014 +0200
     1.3 @@ -0,0 +1,65 @@
     1.4 +#
     1.5 +# Copyright (C) 2014 Guido Berhoerster <guido+relmon@berhoerster.name>
     1.6 +#
     1.7 +# Permission is hereby granted, free of charge, to any person obtaining
     1.8 +# a copy of this software and associated documentation files (the
     1.9 +# "Software"), to deal in the Software without restriction, including
    1.10 +# without limitation the rights to use, copy, modify, merge, publish,
    1.11 +# distribute, sublicense, and/or sell copies of the Software, and to
    1.12 +# permit persons to whom the Software is furnished to do so, subject to
    1.13 +# the following conditions:
    1.14 +#
    1.15 +# The above copyright notice and this permission notice shall be included
    1.16 +# in all copies or substantial portions of the Software.
    1.17 +#
    1.18 +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
    1.19 +# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
    1.20 +# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
    1.21 +# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
    1.22 +# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
    1.23 +# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
    1.24 +# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    1.25 +#
    1.26 +
    1.27 +PACKAGE =	relmon
    1.28 +VERSION =	1
    1.29 +DISTNAME :=	$(PACKAGE)-$(VERSION)
    1.30 +
    1.31 +INSTALL :=	install
    1.32 +INSTALL.exec :=	$(INSTALL) -D -m 0755
    1.33 +INSTALL.data :=	$(INSTALL) -D -m 0644
    1.34 +PAX :=		pax
    1.35 +GZIP :=		gzip
    1.36 +SED :=		sed
    1.37 +TCLSH_PATH :=	/usr/bin/tclsh
    1.38 +
    1.39 +DESTDIR ?=
    1.40 +prefix ?=	/usr/local
    1.41 +bindir ?=	$(prefix)/bin
    1.42 +
    1.43 +SCRIPTS =	$(PACKAGE).tcl
    1.44 +
    1.45 +.DEFAULT_TARGET = all
    1.46 +
    1.47 +.PHONY: all clean clobber dist install
    1.48 +
    1.49 +all: $(PACKAGE)
    1.50 +
    1.51 +$(PACKAGE): $(SCRIPTS)
    1.52 +	cp $< $@
    1.53 +
    1.54 +%.tcl: %.tcl.in
    1.55 +	$(SED) -e '1s,#!.*,#!$(TCLSH_PATH),' -e 's,@VERSION@,$(VERSION),' $< \
    1.56 +	    > $@
    1.57 +
    1.58 +install:
    1.59 +	$(INSTALL.exec) $(PACKAGE) "$(DESTDIR)$(bindir)/$(PACKAGE)"
    1.60 +
    1.61 +clean:
    1.62 +	rm -f $(PACKAGE) $(SCRIPTS)
    1.63 +
    1.64 +clobber: clean
    1.65 +
    1.66 +dist: clobber
    1.67 +	$(PAX) -w -x ustar -s ',.*/\..*,,' -s ',./[^/]*\.tar\.gz,,' \
    1.68 +	    -s ',\./,$(DISTNAME)/,' . | $(GZIP) > $(DISTNAME).tar.gz
     2.1 --- a/README	Sun Oct 19 21:32:37 2014 +0200
     2.2 +++ b/README	Mon Oct 20 19:31:20 2014 +0200
     2.3 @@ -20,8 +20,8 @@
     2.4  Requirements
     2.5  ------------
     2.6  
     2.7 -relmon requires Tcl 8.5 or later, tcllib, tls, and tdom. It has been tested on
     2.8 -Linux distributions and FreeBSD.
     2.9 +relmon requires GNU make, GNU or BSD install, Tcl 8.5 or later, tcllib, tls,
    2.10 +and tdom. It has been tested on Linux distributions and FreeBSD.
    2.11  
    2.12  License
    2.13  -------
     3.1 --- a/relmon.tcl	Sun Oct 19 21:32:37 2014 +0200
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,1706 +0,0 @@
     3.4 -#!/usr/bin/tclsh
     3.5 -#
     3.6 -# Copyright (C) 2014 Guido Berhoerster <guido+relmon@berhoerster.name>
     3.7 -#
     3.8 -# Permission is hereby granted, free of charge, to any person obtaining
     3.9 -# a copy of this software and associated documentation files (the
    3.10 -# "Software"), to deal in the Software without restriction, including
    3.11 -# without limitation the rights to use, copy, modify, merge, publish,
    3.12 -# distribute, sublicense, and/or sell copies of the Software, and to
    3.13 -# permit persons to whom the Software is furnished to do so, subject to
    3.14 -# the following conditions:
    3.15 -#
    3.16 -# The above copyright notice and this permission notice shall be included
    3.17 -# in all copies or substantial portions of the Software.
    3.18 -#
    3.19 -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
    3.20 -# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
    3.21 -# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
    3.22 -# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
    3.23 -# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
    3.24 -# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
    3.25 -# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    3.26 -
    3.27 -package require Tcl 8.5
    3.28 -package require http
    3.29 -package require tls
    3.30 -package require tdom
    3.31 -package require try
    3.32 -package require cmdline
    3.33 -package require control
    3.34 -package require html
    3.35 -package require htmlparse
    3.36 -package require json
    3.37 -package require json::write
    3.38 -package require logger
    3.39 -package require logger::utils
    3.40 -package require textutil::split
    3.41 -package require uri
    3.42 -package require uri::urn
    3.43 -
    3.44 -
    3.45 -namespace eval ::relmon {
    3.46 -    # version
    3.47 -    variable VERSION 1
    3.48 -}
    3.49 -
    3.50 -
    3.51 -namespace eval ::relmon::common {
    3.52 -    namespace export cmpVersions isUrlValid urlGetHost normalizeHttpHeaders \
    3.53 -            parseStateFile
    3.54 -}
    3.55 -
    3.56 -# implementation of the Debian version comparison algorithm described at
    3.57 -# http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version
    3.58 -proc ::relmon::common::cmpVersion {v1 v2} {
    3.59 -    set v1Len [string length $v1]
    3.60 -    set v2Len [string length $v2]
    3.61 -    set v1Pos 0
    3.62 -    set v2Pos 0
    3.63 -    while {($v1Pos < $v1Len) || ($v2Pos < $v2Len)} {
    3.64 -        set firstNumDiff 0
    3.65 -        # until reaching ASCII digits in both version strings compare character
    3.66 -        # values which are modified as so they are sorted in the following
    3.67 -        # order:
    3.68 -        # - "~"
    3.69 -        # - missing character or ASCII digits
    3.70 -        # - ASCII alphabet
    3.71 -        # - everything else in the order of their unicode value
    3.72 -        while {(($v1Pos < $v1Len) &&
    3.73 -                ![string match {[0123456789]} [string index $v1 $v1Pos]]) ||
    3.74 -                (($v2Pos < $v2Len) &&
    3.75 -                ![string match {[0123456789]} [string index $v2 $v2Pos]])} {
    3.76 -            foreach char [list [string index $v1 $v1Pos] \
    3.77 -                    [string index $v2 $v2Pos]] charValueName \
    3.78 -                    {v1CharValue v2CharValue} {
    3.79 -                if {$char eq "~"} {
    3.80 -                    set $charValueName -1
    3.81 -                } elseif {$char eq ""} {
    3.82 -                    set $charValueName 0
    3.83 -                } elseif {[string match {[0123456789]} $char]} {
    3.84 -                    set $charValueName 0
    3.85 -                } elseif {[string match -nocase {[abcdefghijklmnopqrstuvwxyz]} \
    3.86 -                        $char]} {
    3.87 -                    set $charValueName [scan $char "%c"]
    3.88 -                } else {
    3.89 -                    set $charValueName [expr {[scan $char "%c"] + 0x7f + 1}]
    3.90 -                }
    3.91 -            }
    3.92 -            if {$v1CharValue != $v2CharValue} {
    3.93 -                return [expr {$v1CharValue - $v2CharValue}]
    3.94 -            }
    3.95 -            incr v1Pos
    3.96 -            incr v2Pos
    3.97 -        }
    3.98 -
    3.99 -        # strip leading zeros
   3.100 -        while {[string index $v1 $v1Pos] eq "0"} {
   3.101 -            incr v1Pos
   3.102 -        }
   3.103 -        while {[string index $v2 $v2Pos] eq "0"} {
   3.104 -            incr v2Pos
   3.105 -        }
   3.106 -
   3.107 -        # process digits until reaching a non-digit
   3.108 -        while {[string match {[0123456789]} [string index $v1 $v1Pos]] &&
   3.109 -                [string match {[0123456789]} [string index $v2 $v2Pos]]} {
   3.110 -            # record the first difference between the two numbers
   3.111 -            if {$firstNumDiff == 0} {
   3.112 -                set firstNumDiff [expr {[string index $v1 $v1Pos] -
   3.113 -                        [string index $v2 $v2Pos]}]
   3.114 -            }
   3.115 -            incr v1Pos
   3.116 -            incr v2Pos
   3.117 -        }
   3.118 -
   3.119 -        # return if the number of one version has more digits than the other
   3.120 -        # since the one with more digits is the larger number
   3.121 -        if {[string match {[0123456789]} [string index $v1 $v1Pos]]} {
   3.122 -            return 1
   3.123 -        } elseif {[string match {[0123456789]} [string index $v2 $v2Pos]]} {
   3.124 -            return -1
   3.125 -        }
   3.126 -
   3.127 -        # return the difference if the digits differed above
   3.128 -        if {$firstNumDiff != 0} {
   3.129 -            return $firstNumDiff
   3.130 -        }
   3.131 -    }
   3.132 -
   3.133 -    return 0
   3.134 -}
   3.135 -
   3.136 -proc ::relmon::common::isUrlValid {url} {
   3.137 -    return [expr {![catch {dict create {*}[uri::split $url]} urlParts] &&
   3.138 -            ([dict get $urlParts "scheme"] in {"http" "https"}) &&
   3.139 -            ([dict get $urlParts "host"] ne "")}]
   3.140 -}
   3.141 -
   3.142 -proc ::relmon::common::urlGetHost {url} {
   3.143 -    return [expr {(![catch {dict create {*}[uri::split $url]} urlParts]) ?
   3.144 -                [dict get $urlParts "host"] : ""}]
   3.145 -}
   3.146 -
   3.147 -proc ::relmon::common::normalizeHttpHeaders {headers} {
   3.148 -    set httpHeaders [dict create]
   3.149 -    foreach {header value} $headers {
   3.150 -        set words {}
   3.151 -        foreach word [split $header "-"] {
   3.152 -            lappend words [string totitle $word]
   3.153 -        }
   3.154 -        dict set httpHeaders [join $words "-"] $value
   3.155 -    }
   3.156 -    return $httpHeaders
   3.157 -}
   3.158 -
   3.159 -proc ::relmon::common::parseStateFile {stateFile} {
   3.160 -    try {
   3.161 -        set f [open $stateFile "r"]
   3.162 -    } trap {POSIX} {errorMsg errorOptions} {
   3.163 -        return -options $errorOptions \
   3.164 -                "failed to open state file \"$stateFile\": $errorMsg"
   3.165 -    }
   3.166 -    try {
   3.167 -        set state [json::json2dict [chan read $f]]
   3.168 -    } trap {POSIX} {errorMsg errorOptions} {
   3.169 -        return -options $errorOptions \
   3.170 -                "failed to read from state file \"$stateFile\": $errorMsg"
   3.171 -    } on error {errorMsg errorOptions} {
   3.172 -        # the json package does not set an error code
   3.173 -        dict set errorOptions "-errorcode" {RELMON JSON_PARSE_ERROR}
   3.174 -        return -options $errorOptions \
   3.175 -                "failed to parse state file \"$stateFile\": $errorMsg"
   3.176 -    } finally {
   3.177 -        close $f
   3.178 -    }
   3.179 -
   3.180 -    return $state
   3.181 -}
   3.182 -
   3.183 -
   3.184 -namespace eval ::relmon::update {
   3.185 -    # commandline option help text
   3.186 -    variable usage "usage: relmon update \[-dev\] \[-c max_connections\] \[-C\
   3.187 -            ca_dir\] \[-D delay\]\n\
   3.188 -            \                    \[-H max_host_connections\] \[-i\
   3.189 -            item\[,...\]\] \[-l logfile\]\n\
   3.190 -            \                    \[-r retries\] \[-t min_time\] watchlist\
   3.191 -            statefile"
   3.192 -
   3.193 -    # configuration options
   3.194 -    variable Config [dict create \
   3.195 -            "log_file" "" \
   3.196 -            "log_level" "notice" \
   3.197 -            "history_limit" 20 \
   3.198 -            "connection_limit" 16 \
   3.199 -            "host_connection_limit" 4 \
   3.200 -            "transfer_time_limit" 60000 \
   3.201 -            "retry_limit" 3 \
   3.202 -            "host_delay" 0 \
   3.203 -            "timestamp_filter" 0 \
   3.204 -            "error_filter" 0 \
   3.205 -            "item_filter" {} \
   3.206 -            "ca_dir" "" \
   3.207 -            "state_file" "" \
   3.208 -            "watchlist_file" ""]
   3.209 -
   3.210 -    # exit status
   3.211 -    variable ExitStatus
   3.212 -
   3.213 -    # transfer statistics
   3.214 -    variable Statistics [dict create \
   3.215 -            "start_time" 0 \
   3.216 -            "end_time" 0 \
   3.217 -            "requests" 0 \
   3.218 -            "items" 0]
   3.219 -
   3.220 -    # watchlist
   3.221 -    variable Watchlist
   3.222 -
   3.223 -    # ID of a delayed run of ManageTransfers
   3.224 -    variable ManageTransfersId ""
   3.225 -
   3.226 -    # queue of pending transfers
   3.227 -    variable Queue
   3.228 -
   3.229 -    # number of active connections per host
   3.230 -    variable HostConnections
   3.231 -
   3.232 -    # delays before opening a new connection to a host
   3.233 -    variable HostDelays
   3.234 -
   3.235 -    # active transfers
   3.236 -    variable ActiveTransfers
   3.237 -
   3.238 -    # buffer for tracking the state of unfinished items
   3.239 -    variable StateBuffer
   3.240 -
   3.241 -    # buffer needed by htmlparse::parse for constructing the preprocessed HTML
   3.242 -    # document
   3.243 -    variable PreprocessedHtmlBuffer
   3.244 -
   3.245 -    # logger handle
   3.246 -    variable Log
   3.247 -
   3.248 -    # logfile handle
   3.249 -    variable Lf
   3.250 -}
   3.251 -
   3.252 -proc ::relmon::update::OnError {message returnOptions} {
   3.253 -    # internal error, abort
   3.254 -    puts stderr [dict get $returnOptions "-errorinfo"]
   3.255 -
   3.256 -    exit 1
   3.257 -}
   3.258 -
   3.259 -proc ::relmon::update::CleanupBeforeExit {commandString operation} {
   3.260 -    variable Lf
   3.261 -
   3.262 -    # close logfile
   3.263 -    if {($Lf ne "") && ($Lf ni {stdin stderr})} {
   3.264 -        close $Lf
   3.265 -        set Lf ""
   3.266 -    }
   3.267 -
   3.268 -    return
   3.269 -}
   3.270 -
   3.271 -proc ::relmon::update::ParseWatchlist {watchlistFilename} {
   3.272 -    variable Watchlist
   3.273 -
   3.274 -    set lineno 0
   3.275 -    set f [open $watchlistFilename "r"]
   3.276 -    try {
   3.277 -        while {[chan gets $f line] != -1} {
   3.278 -            set fields [textutil::split::splitx [string trim $line] {[\t ]+}]
   3.279 -            incr lineno
   3.280 -
   3.281 -            if {([llength $fields] == 0) ||
   3.282 -                    ([string index [lindex $fields 0] 0] eq "#")} {
   3.283 -                # skip empty lines and comments
   3.284 -                continue
   3.285 -            } elseif {[llength $fields] < 3} {
   3.286 -                # a line consists of a name, base URL and at least one
   3.287 -                # version-matching pattern
   3.288 -                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   3.289 -                        "syntax error in \"$watchlistFilename\" line $lineno"
   3.290 -            }
   3.291 -
   3.292 -            set patterns [lassign $fields name baseUrl]
   3.293 -
   3.294 -            # validate URL
   3.295 -            if {![::relmon::common::isUrlValid $baseUrl]} {
   3.296 -                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   3.297 -                        "syntax error in \"$watchlistFilename\" line $lineno:\
   3.298 -                        invalid base URL"
   3.299 -            }
   3.300 -
   3.301 -            # process patterns
   3.302 -            set processedPatterns {}
   3.303 -            set patternIndex 0
   3.304 -            foreach pattern $patterns {
   3.305 -                incr patternIndex
   3.306 -
   3.307 -                # make trailing slashes optional except in the last
   3.308 -                # version-matching pattern
   3.309 -                if {($patternIndex != [llength $patterns]) &&
   3.310 -                        ([string index $pattern end] eq "/")} {
   3.311 -                    append pattern {?}
   3.312 -                }
   3.313 -
   3.314 -                # ensure patterns are anchored to the end of the line
   3.315 -                if {[string index $pattern end] ne "$"} {
   3.316 -                    append pattern {$}
   3.317 -                }
   3.318 -
   3.319 -                # actually validate the regular expression
   3.320 -                try {
   3.321 -                    set reInfo [regexp -about -- $pattern ""]
   3.322 -                } on error {errorMsg} {
   3.323 -                    return -code error \
   3.324 -                            -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   3.325 -                            "error in \"$watchlistFilename\" line $lineno:\
   3.326 -                            $errorMsg"
   3.327 -                }
   3.328 -                lappend processedPatterns $pattern
   3.329 -            }
   3.330 -            if {[lindex $reInfo 0] < 1} {
   3.331 -                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   3.332 -                        "syntax error in \"$watchlistFilename\" line $lineno:\
   3.333 -                        the last regular expression must contain at least one
   3.334 -                        capturing group"
   3.335 -            }
   3.336 -
   3.337 -            dict set Watchlist $name "base_url" $baseUrl
   3.338 -            dict set Watchlist $name "patterns" $processedPatterns
   3.339 -        }
   3.340 -    } finally {
   3.341 -        close $f
   3.342 -    }
   3.343 -
   3.344 -    return
   3.345 -}
   3.346 -
   3.347 -proc ::relmon::update::ProcessHtmlElement {tag slash param textBehindTheTag} {
   3.348 -    variable PreprocessedHtmlBuffer
   3.349 -
   3.350 -    # copy every "<a>" element into PreprocessedHtmlBuffer
   3.351 -    if {($slash eq "") && ([string tolower $tag] eq "a")} {
   3.352 -        append PreprocessedHtmlBuffer "<$tag $param></$tag>"
   3.353 -    }
   3.354 -
   3.355 -    return
   3.356 -}
   3.357 -
   3.358 -proc ::relmon::update::PreprocessHtml {bodyDataName} {
   3.359 -    upvar 1 $bodyDataName bodyData
   3.360 -    variable PreprocessedHtmlBuffer
   3.361 -
   3.362 -    # preprocess the document with htmlparse by constructing a new document
   3.363 -    # consisting only of found "<a>" elements which then can be fed into tdom
   3.364 -    # again; this is useful if parsing via tdom fails; however, htmlparse
   3.365 -    # should only be used as a last resort because it is just too limited, it
   3.366 -    # gets easily confused within "<script>" elements and lacks attribute
   3.367 -    # parsing
   3.368 -    set PreprocessedHtmlBuffer "<html><body>"
   3.369 -    htmlparse::parse -cmd [namespace code ProcessHtmlElement] $bodyData
   3.370 -    append PreprocessedHtmlBuffer "</body></html>"
   3.371 -}
   3.372 -
   3.373 -proc ::relmon::update::ExtractUrls {bodyDataName contentType baseUrl
   3.374 -        rePattern} {
   3.375 -    upvar 1 $bodyDataName bodyData
   3.376 -    set extractedUrls {}
   3.377 -    set resultUrls [dict create]
   3.378 -    # extract all URLs or URL fragments
   3.379 -    switch -- $contentType {
   3.380 -        {text/html} -
   3.381 -        {application/xhtml+xml} {
   3.382 -            # HTML/XHTML
   3.383 -            # if tdom parsing has failed or not found any "<a>" element,
   3.384 -            # preprocess the document with htmlparse and try again
   3.385 -            if {[catch {dom parse -html $bodyData} doc] ||
   3.386 -                    ([set rootElement [$doc documentElement]] eq "") ||
   3.387 -                    ([llength [set aElements \
   3.388 -                    [$rootElement selectNodes {descendant::a}]]] == 0)} {
   3.389 -                try {
   3.390 -                    set doc [dom parse -html [PreprocessHtml bodyData]]
   3.391 -                } on error {errorMsg errorOptions} {
   3.392 -                    dict set errorOptions "-errorcode" \
   3.393 -                            {RELMON TDOM_PARSE_ERROR}
   3.394 -                    return -options $errorOptions $errorMsg
   3.395 -                }
   3.396 -                set rootElement [$doc documentElement]
   3.397 -                set aElements [$rootElement selectNodes {descendant::a}]
   3.398 -            }
   3.399 -            foreach node $aElements {
   3.400 -                set href [$node getAttribute "href" ""]
   3.401 -                if {$href ne ""} {
   3.402 -                    lappend extractedUrls $href
   3.403 -                }
   3.404 -            }
   3.405 -            $doc delete
   3.406 -        }
   3.407 -        {application/rss+xml} {
   3.408 -            # RSS 2.0
   3.409 -            try {
   3.410 -                set doc [dom parse $bodyData]
   3.411 -            } on error {errorMsg errorOptions} {
   3.412 -                dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
   3.413 -                return -options $errorOptions $errorMsg
   3.414 -            }
   3.415 -            set rootElement [$doc documentElement]
   3.416 -            if {$rootElement ne ""} {
   3.417 -                foreach node [$rootElement selectNodes {descendant::link}] {
   3.418 -                    set linkText [$node text]
   3.419 -                    if {$linkText ne ""} {
   3.420 -                        lappend extractedUrls $linkText
   3.421 -                    }
   3.422 -                }
   3.423 -            }
   3.424 -            $doc delete
   3.425 -        }
   3.426 -        {application/atom+xml} {
   3.427 -            # Atom 1.0
   3.428 -            try {
   3.429 -                set doc [dom parse $bodyData]
   3.430 -            } on error {errorMsg errorOptions} {
   3.431 -                dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
   3.432 -                return -options $errorOptions $errorMsg
   3.433 -            }
   3.434 -            set rootElement [$doc documentElement]
   3.435 -            if {$rootElement ne ""} {
   3.436 -                foreach node [$rootElement selectNodes {descendant::link}] {
   3.437 -                    set href [$node getAttribute "href" ""]
   3.438 -                    if {$href ne ""} {
   3.439 -                        lappend extractedUrls $href
   3.440 -                    }
   3.441 -                }
   3.442 -            }
   3.443 -            $doc delete
   3.444 -        }
   3.445 -        {text/plain} {
   3.446 -            # plain text
   3.447 -            foreach line [split $bodyData "\n"] {
   3.448 -                if {$line ne ""} {
   3.449 -                    lappend extractedUrls $line
   3.450 -                }
   3.451 -            }
   3.452 -        }
   3.453 -        default {
   3.454 -            return -code error \
   3.455 -                    -errorcode {RELMON UNSUPPORTED_CONTENT_TYPE_ERROR} \
   3.456 -                    "unsupported content type \"$contentType\""
   3.457 -        }
   3.458 -    }
   3.459 -    foreach url $extractedUrls {
   3.460 -        set normalizedUrl [uri::canonicalize [uri::resolve $baseUrl $url]]
   3.461 -        dict set resultUrls $normalizedUrl \
   3.462 -                [expr {[regexp -line -- $rePattern $normalizedUrl] ? 1 : 0}]
   3.463 -    }
   3.464 -
   3.465 -    return $resultUrls
   3.466 -}
   3.467 -
   3.468 -proc ::relmon::update::StateItemAppendError {name logMsg} {
   3.469 -    variable StateBuffer
   3.470 -
   3.471 -    dict update StateBuffer $name stateItem {
   3.472 -        dict lappend stateItem "errors" $logMsg
   3.473 -    }
   3.474 -
   3.475 -    return
   3.476 -}
   3.477 -
   3.478 -proc ::relmon::update::HandleSuccessfulTransfer {item httpBodyName} {
   3.479 -    upvar 1 $httpBodyName httpBody
   3.480 -    variable Log
   3.481 -    variable StateBuffer
   3.482 -    variable Queue
   3.483 -    variable Watchlist
   3.484 -
   3.485 -    set name [dict get $item "name"]
   3.486 -    set url [dict get $item "url"]
   3.487 -    set patternIndex [dict get $item "pattern_index"]
   3.488 -    set pattern [lindex [dict get $Watchlist $name "patterns"] $patternIndex]
   3.489 -
   3.490 -    ${Log}::info "\"$name\": \"$url\": transfer finished"
   3.491 -
   3.492 -    # parse data
   3.493 -    try {
   3.494 -        set urls [ExtractUrls httpBody [dict get $item "content_type"] $url \
   3.495 -                $pattern]
   3.496 -    } trap {RELMON} {errorMsg} {
   3.497 -        # continue on tdom parsing errors or when receiving documents with an
   3.498 -        # unsupported content type
   3.499 -        set urls [dict create]
   3.500 -        set warningMsg "\"$name\": \"$url\": failed to parse data: $errorMsg"
   3.501 -        ${Log}::warn $warningMsg
   3.502 -        StateItemAppendError $name $warningMsg
   3.503 -    }
   3.504 -
   3.505 -    if {$patternIndex < ([llength \
   3.506 -            [dict get $Watchlist $name "patterns"]] - 1)} {
   3.507 -        # if this is not the last, version-matching pattern, queue matched URLs
   3.508 -        dict for {newUrl matched} $urls {
   3.509 -            if {$matched} {
   3.510 -                if {![::relmon::common::isUrlValid $newUrl]} {
   3.511 -                    ${Log}::debug "\"$name\": \"$url\": ignoring matched but\
   3.512 -                            invalid URL \"$newUrl\""
   3.513 -                    continue
   3.514 -                }
   3.515 -
   3.516 -                ${Log}::debug "\"$name\": \"$url\": queuing \"$newUrl\""
   3.517 -
   3.518 -                dict lappend Queue [::relmon::common::urlGetHost $newUrl] \
   3.519 -                        [dict create "name" $name "url" $newUrl \
   3.520 -                        "pattern_index" [expr {$patternIndex + 1}] \
   3.521 -                        "content_type" "" "num_redirects" 0 "num_retries" 0]
   3.522 -            } else {
   3.523 -                ${Log}::debug "\"$name\": \"$url\": ignoring \"$newUrl\""
   3.524 -            }
   3.525 -        }
   3.526 -    } else {
   3.527 -        # otherwise this branch has finished, try to extract the versions and
   3.528 -        # store them in the buffer
   3.529 -        dict for {finalUrl matched} $urls {
   3.530 -            if {$matched} {
   3.531 -                regexp -line -- $pattern $finalUrl -> version
   3.532 -                if {$version ne ""} {
   3.533 -                    ${Log}::debug "\"$name\": \"$url\": extracted version\
   3.534 -                            \"$version\" from \"$finalUrl\" found on\
   3.535 -                            \"$url\""
   3.536 -                    dict set StateBuffer $name "versions" $version $finalUrl
   3.537 -                } else {
   3.538 -                    ${og}::debug "\"$name\": \"$url\": could not extract a\
   3.539 -                            version from \"$finalUrl\""
   3.540 -                }
   3.541 -            } else {
   3.542 -                ${Log}::debug "\"$name\": \"$url\": ignoring \"$finalUrl\""
   3.543 -            }
   3.544 -        }
   3.545 -    }
   3.546 -
   3.547 -    return
   3.548 -}
   3.549 -
   3.550 -proc ::relmon::update::HandleRedirect {item httpCode httpHeaders} {
   3.551 -    variable Log
   3.552 -    variable Queue
   3.553 -
   3.554 -    set name [dict get $item "name"]
   3.555 -    set url [dict get $item "url"]
   3.556 -
   3.557 -    if {![dict exists $httpHeaders "Location"]} {
   3.558 -        # bail out in case of an invalid HTTP response
   3.559 -        set warningMsg "\"$name\": \"$url\": transfer failed: invalid HTTP\
   3.560 -                response"
   3.561 -        ${Log}::warn $warningMsg
   3.562 -        StateItemAppendError $name $warningMsg
   3.563 -        return
   3.564 -    }
   3.565 -    set location [dict get $httpHeaders "Location"]
   3.566 -
   3.567 -    # sanitize URL from Location header
   3.568 -    if {[uri::isrelative $location]} {
   3.569 -        set redirectUrl [uri::canonicalize [uri::resolve \
   3.570 -                $url $location]]
   3.571 -    } else {
   3.572 -        if {![::relmon::common::isUrlValid $location]} {
   3.573 -            # bail out in case of an invalid redirect URL
   3.574 -            set warningMsg "\"$name\": \"$url\": received invalid redirect URL\
   3.575 -                    \"$location\""
   3.576 -            ${Log}::warn $warningMsg
   3.577 -            StateItemAppendError $name $warningMsg
   3.578 -            return
   3.579 -        }
   3.580 -        set redirectUrl [uri::canonicalize $location]
   3.581 -    }
   3.582 -
   3.583 -    ${Log}::notice "\"$name\": \"$url\": received redirect to \"$redirectUrl\""
   3.584 -
   3.585 -    # handle up to 10 redirects by re-queuing the target URL
   3.586 -    if {[dict get $item "num_redirects"] < 10} {
   3.587 -        ${Log}::debug "\"$name\": \"$url\": queuing \"$redirectUrl\" due to\
   3.588 -                redirect"
   3.589 -
   3.590 -        dict lappend Queue [::relmon::common::urlGetHost $redirectUrl] \
   3.591 -                [dict replace $item "url" $redirectUrl "content_type" "" \
   3.592 -                "num_redirects" [expr {[dict get $item "num_redirects"] + 1}] \
   3.593 -                "num_retries" 0]
   3.594 -    } else {
   3.595 -        set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
   3.596 -                redirects"
   3.597 -        ${Log}::warn $warningMsg
   3.598 -        StateItemAppendError $name $warningMsg
   3.599 -    }
   3.600 -
   3.601 -    return
   3.602 -}
   3.603 -
   3.604 -proc ::relmon::update::HandleProtocolError {item httpCode} {
   3.605 -    variable Log
   3.606 -    set name [dict get $item "name"]
   3.607 -    set url [dict get $item "url"]
   3.608 -    set warningMsg "\"$name\": \"$url\": transfer failed: $httpCode"
   3.609 -    ${Log}::warn $warningMsg
   3.610 -    StateItemAppendError $name $warningMsg
   3.611 -    return
   3.612 -}
   3.613 -
   3.614 -proc ::relmon::update::HandleTimeoutReset {item} {
   3.615 -    variable Log
   3.616 -    variable Config
   3.617 -    variable Queue
   3.618 -    set name [dict get $item "name"]
   3.619 -    set url [dict get $item "url"]
   3.620 -
   3.621 -    # retry by re-queuing the target URL until reaching the limit
   3.622 -    if {[dict get $item "num_retries"] < [dict get $Config "retry_limit"]} {
   3.623 -        ${Log}::warn "\"$name\": \"$url\": connection timed out or was reset,\
   3.624 -                retrying"
   3.625 -        dict lappend Queue [::relmon::common::urlGetHost $url] \
   3.626 -                [dict replace $item \
   3.627 -                "num_retries" [expr {[dict get $item "num_retries"] + 1}]]
   3.628 -    } else {
   3.629 -        set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
   3.630 -                retries"
   3.631 -        ${Log}::warn $warningMsg
   3.632 -        StateItemAppendError $name $warningMsg
   3.633 -    }
   3.634 -
   3.635 -    return
   3.636 -}
   3.637 -
   3.638 -proc ::relmon::update::HandleConnectionError {item errorMsg} {
   3.639 -    variable Log
   3.640 -    set name [dict get $item "name"]
   3.641 -    set url [dict get $item "url"]
   3.642 -    set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
   3.643 -    ${Log}::warn $warningMsg
   3.644 -    StateItemAppendError $name $warningMsg
   3.645 -    return
   3.646 -}
   3.647 -
   3.648 -proc ::relmon::update::TransferCallbackWrapper {callbackCmd args} {
   3.649 -    # ensure that exceptions get raised, by default http catches all errors and
   3.650 -    # silently ignores them, see https://core.tcl.tk/tcl/tktview?name=1414262
   3.651 -    if {[catch {eval $callbackCmd $args} -> errorOptions]} {
   3.652 -        OnError [dict get $errorOptions "-errorinfo"] $errorOptions
   3.653 -    }
   3.654 -    return
   3.655 -}
   3.656 -
   3.657 -proc ::relmon::update::ManageTransfers {} {
   3.658 -    variable Config
   3.659 -    variable ManageTransfersId
   3.660 -    variable Queue
   3.661 -    variable HostConnections
   3.662 -    variable HostDelays
   3.663 -    variable ActiveTransfers
   3.664 -    variable ExitStatus
   3.665 -    variable Log
   3.666 -
   3.667 -    after cancel $ManageTransfersId
   3.668 -
   3.669 -    # try to initiate new transfers
   3.670 -    while {([dict size $ActiveTransfers] <
   3.671 -            [dict get $Config "connection_limit"]) &&
   3.672 -            ([dict size $Queue] > 0)} {
   3.673 -        # find URLs in the queue with a host for which we have not reached the
   3.674 -        # per-host connection limit yet and for which no delay is in effect
   3.675 -        set item {}
   3.676 -        dict for {host items} $Queue {
   3.677 -            set now [clock milliseconds]
   3.678 -
   3.679 -            if {![dict exists $HostConnections $host]} {
   3.680 -                dict set HostConnections $host 0
   3.681 -            }
   3.682 -
   3.683 -            if {![dict exists $HostDelays $host]} {
   3.684 -                dict set HostDelays $host $now
   3.685 -            }
   3.686 -
   3.687 -            if {([dict get $HostConnections $host] <
   3.688 -                    [dict get $Config "host_connection_limit"]) &&
   3.689 -                    ([dict get $HostDelays $host] <= $now)} {
   3.690 -                # pop item from the queue
   3.691 -                set items [lassign $items item]
   3.692 -                if {[llength $items] > 0} {
   3.693 -                    dict set Queue $host $items
   3.694 -                } else {
   3.695 -                    dict unset Queue $host
   3.696 -                }
   3.697 -
   3.698 -                dict incr HostConnections $host
   3.699 -                # set a random delay before the next connection to this host
   3.700 -                # can be made
   3.701 -                dict set HostDelays $host \
   3.702 -                        [expr {[clock milliseconds] + int((rand() + 0.5) *
   3.703 -                        [dict get $Config "host_delay"])}]
   3.704 -                break
   3.705 -            }
   3.706 -        }
   3.707 -        # if no item could be found, the per-host connection limit for all
   3.708 -        # queued URLs has been reached and no new transfers may be started
   3.709 -        # at this point
   3.710 -        if {$item eq {}} {
   3.711 -            break
   3.712 -        }
   3.713 -        # otherwise start a new transfer
   3.714 -        set url [dict get $item "url"]
   3.715 -        set name [dict get $item "name"]
   3.716 -        try {
   3.717 -            set token [http::geturl $url \
   3.718 -                    -timeout [dict get $Config "transfer_time_limit"] \
   3.719 -                    -progress [namespace code {TransferCallbackWrapper \
   3.720 -                    OnTransferProgress}] \
   3.721 -                    -command [namespace code {TransferCallbackWrapper \
   3.722 -                    OnTransferFinished}]]
   3.723 -        } on ok {} {
   3.724 -            dict set ActiveTransfers $token $item
   3.725 -
   3.726 -            ${Log}::info "\"$name\": \"$url\": starting transfer"
   3.727 -        } on error {errorMsg} {
   3.728 -            # an error occured during socket setup, e.g. a DNS lookup failure
   3.729 -            set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
   3.730 -            ${Log}::warn $warningMsg
   3.731 -            StateItemAppendError $name $warningMsg
   3.732 -        }
   3.733 -    }
   3.734 -
   3.735 -    # terminate the event loop if there are no remaining transfers
   3.736 -    if {([dict size $ActiveTransfers]) == 0 && ([dict size $Queue] == 0)} {
   3.737 -        set ExitStatus 0
   3.738 -        return
   3.739 -    }
   3.740 -
   3.741 -    # due to per-host connection limits and per-host delays the maximum number
   3.742 -    # of connections may not be reached although there are still items in the
   3.743 -    # queue, in this case schedule ManageTransfers again after the smallest of
   3.744 -    # the current per-host delays
   3.745 -    set delay 0
   3.746 -    if {([dict size $ActiveTransfers] <
   3.747 -            [dict get $Config "connection_limit"]) &&
   3.748 -            ([dict size $Queue] > 0)} {
   3.749 -        dict for {host items} $Queue {
   3.750 -            if {(![dict exists $HostConnections $host] ||
   3.751 -                    ([dict get $HostConnections $host] <
   3.752 -                    [dict get $Config "host_connection_limit"])) &&
   3.753 -                    ([dict exists $HostDelays $host] &&
   3.754 -                    ([dict get $HostDelays $host] > $now))} {
   3.755 -                set hostDelay [expr {[dict get $HostDelays $host] - $now + 1}]
   3.756 -                if {(($delay == 0) ||
   3.757 -                        ($hostDelay < $delay))} {
   3.758 -                    set delay $hostDelay
   3.759 -                }
   3.760 -            }
   3.761 -        }
   3.762 -        if {$delay > 0} {
   3.763 -            set ManageTransfersId \
   3.764 -                    [after $delay [namespace code ManageTransfers]]
   3.765 -        }
   3.766 -    }
   3.767 -
   3.768 -    return
   3.769 -}
   3.770 -
   3.771 -proc ::relmon::update::OnTransferProgress {token total current} {
   3.772 -    upvar #0 $token httpState
   3.773 -    variable ActiveTransfers
   3.774 -    variable Log
   3.775 -
   3.776 -    # try to determine content type and abort transfer if content type is not
   3.777 -    # one that can be parsed, this is primarily to prevent accidental downloads
   3.778 -    if {[dict get $ActiveTransfers $token "content_type"] eq ""} {
   3.779 -        set httpHeaders [relmon::common::normalizeHttpHeaders \
   3.780 -                $httpState(meta)]
   3.781 -
   3.782 -        if {[dict exists $httpHeaders "Content-Type"]} {
   3.783 -            set contentType [string trim [lindex [split \
   3.784 -                    [dict get $httpHeaders "Content-Type"] ";"] 0]]
   3.785 -            dict set ActiveTransfers $token "content_type" $contentType
   3.786 -            if {$contentType ni {"text/html" "application/xhtml+xml"
   3.787 -                    "application/atom+xml" "application/rss+xml"
   3.788 -                    "text/plain"}} {
   3.789 -                ${Log}::warn "\"[dict get $ActiveTransfers $token "name"]\":\
   3.790 -                        \"[dict get $ActiveTransfers $token "url"]\": content\
   3.791 -                        type \"$contentType\" is not acceptable"
   3.792 -                http::reset $token
   3.793 -            }
   3.794 -        }
   3.795 -    }
   3.796 -}
   3.797 -
   3.798 -proc ::relmon::update::OnTransferFinished {token} {
   3.799 -    upvar #0 $token httpState
   3.800 -    variable Config
   3.801 -    variable HostConnections
   3.802 -    variable Queue
   3.803 -    variable ActiveTransfers
   3.804 -    variable Statistics
   3.805 -    variable StateBuffer
   3.806 -    variable State
   3.807 -    variable Log
   3.808 -
   3.809 -    set item [dict get $ActiveTransfers $token]
   3.810 -    set name [dict get $item "name"]
   3.811 -    set host [relmon::common::urlGetHost [dict get $item "url"]]
   3.812 -
   3.813 -    # update list of per-host connections, and number of remaining transfers
   3.814 -    # for this item
   3.815 -    dict unset ActiveTransfers $token
   3.816 -    dict incr HostConnections $host -1
   3.817 -
   3.818 -    switch -- $httpState(status) {
   3.819 -        {ok} {
   3.820 -            # normalize headers
   3.821 -            set httpHeaders [relmon::common::normalizeHttpHeaders \
   3.822 -                    $httpState(meta)]
   3.823 -
   3.824 -            # try to determine content type
   3.825 -            if {([dict get $item "content_type"] eq "") &&
   3.826 -                    [dict exists $httpHeaders "Content-Type"]} {
   3.827 -                dict set item "content_type" [string trim [lindex [split \
   3.828 -                        [dict get $httpHeaders "Content-Type"] ";"] 0]]
   3.829 -            }
   3.830 -
   3.831 -            # dispatch based on HTTP status code
   3.832 -            set httpCode [http::ncode $token]
   3.833 -            switch -glob -- $httpCode {
   3.834 -                {30[12378]} {
   3.835 -                    HandleRedirect $item $httpCode $httpHeaders
   3.836 -                }
   3.837 -                {200} {
   3.838 -                    HandleSuccessfulTransfer $item httpState(body)
   3.839 -                }
   3.840 -                default {
   3.841 -                    HandleProtocolError $item $httpState(http)
   3.842 -                }
   3.843 -            }
   3.844 -        }
   3.845 -        {reset} {
   3.846 -            # aborted due to wrong content type
   3.847 -        }
   3.848 -        {eof} -
   3.849 -        {timeout} {
   3.850 -            # timeout or connection reset
   3.851 -            HandleTimeoutReset $item
   3.852 -        }
   3.853 -        {error} {
   3.854 -            # connection may have failed or been refused
   3.855 -            HandleConnectionError $item [lindex $httpState(error) 0]
   3.856 -        }
   3.857 -    }
   3.858 -
   3.859 -    # check if all transfers of this item are finished
   3.860 -    set itemFinished 1
   3.861 -    dict for {queueHost queueItems} $Queue {
   3.862 -        foreach queueItem $queueItems {
   3.863 -            if {[dict get $queueItem "name"] eq $name} {
   3.864 -                set itemFinished 0
   3.865 -            }
   3.866 -        }
   3.867 -    }
   3.868 -    dict for {activeToken activeItem} $ActiveTransfers {
   3.869 -        if {[dict get $activeItem "name"] eq $name} {
   3.870 -            set itemFinished 0
   3.871 -        }
   3.872 -    }
   3.873 -    if {$itemFinished} {
   3.874 -        set timestamp [clock milliseconds]
   3.875 -
   3.876 -        # create httpState item if it does not exist yet
   3.877 -        if {![dict exists $State $name]} {
   3.878 -            dict set State $name [dict create "versions" [dict create] \
   3.879 -                    "history" [list] "timestamp" 0 "errors" [list]]
   3.880 -        }
   3.881 -
   3.882 -        # if there are no versions, log an error message since something must
   3.883 -        # be wrong
   3.884 -        if {[llength [dict get $StateBuffer $name "versions"]] == 0} {
   3.885 -            set warningMsg "\"$name\": no versions found"
   3.886 -            ${Log}::warn $warningMsg
   3.887 -            StateItemAppendError $name $warningMsg
   3.888 -        }
   3.889 -
   3.890 -        # update httpState item
   3.891 -        dict set State $name "errors" [dict get $StateBuffer $name "errors"]
   3.892 -        dict set State $name "timestamp" $timestamp
   3.893 -        if {[llength [dict get $StateBuffer $name "errors"]] == 0} {
   3.894 -            # expire old history entries
   3.895 -            set history [lrange [dict get $State $name "history"] \
   3.896 -                    [expr {[llength [dict get $State $name "history"]] -
   3.897 -                    [dict get $Config "history_limit"] + 1}] end]
   3.898 -
   3.899 -            # add currently latest available version to history if it is either
   3.900 -            # newer than the previous one or if the previous one is no longer
   3.901 -            # available (e.g. if it has been removed or the watchlist pattern
   3.902 -            # has been changed)
   3.903 -            set prevLatestVersion [lindex $history end 0]
   3.904 -            set curLatestVersion [lindex \
   3.905 -                    [lsort -command ::relmon::common::cmpVersion \
   3.906 -                    [dict keys [dict get $StateBuffer $name "versions"]]] end]
   3.907 -            if {([::relmon::common::cmpVersion $curLatestVersion \
   3.908 -                    $prevLatestVersion] > 0) ||
   3.909 -                    ![dict exists $StateBuffer $name "versions" \
   3.910 -                    $prevLatestVersion]} {
   3.911 -                lappend history [list $curLatestVersion $timestamp]
   3.912 -                dict set State $name "history" $history
   3.913 -            }
   3.914 -            dict set State $name "versions" [dict get $StateBuffer $name \
   3.915 -                    "versions"]
   3.916 -        }
   3.917 -        dict unset StateBuffer $name
   3.918 -
   3.919 -        ${Log}::notice "progress: [dict size $StateBuffer]/[dict get \
   3.920 -                $Statistics "items"] items left"
   3.921 -    }
   3.922 -
   3.923 -    http::cleanup $token
   3.924 -
   3.925 -    ManageTransfers
   3.926 -
   3.927 -    return
   3.928 -}
   3.929 -
   3.930 -# control certificate verification and log errors during TLS handshake
   3.931 -proc ::relmon::update::OnTlsHandshake {type args} {
   3.932 -    variable Config
   3.933 -    variable Log
   3.934 -
   3.935 -    switch -- ${type} {
   3.936 -        {error} {
   3.937 -            lassign $args {} tlsErrorMsg
   3.938 -            ${Log}::error "TLS connection error: $tlsErrorMsg"
   3.939 -        }
   3.940 -        {verify} {
   3.941 -            lassign $args {} {} {} status tlsErrorMsg
   3.942 -            array set cert [lindex $args 2]
   3.943 -            if {$status == 0} {
   3.944 -                if {[dict get $Config "ca_dir"] eq ""} {
   3.945 -                    # do not verify certificates is ca-dir was not set
   3.946 -                    return 1
   3.947 -                } else {
   3.948 -                    set errorMsg "$tlsErrorMsg\nCertificate details:"
   3.949 -                    foreach {key description} {"serial" "Serial Number"
   3.950 -                            "issuer" "Issuer" "notBefore" "Not Valid Before"
   3.951 -                            "notAfter" "Not Valid After" "subject" "Subject"
   3.952 -                            "sha1_hash" "SHA1 Hash"} {
   3.953 -                        append errorMsg "\n$description: $cert($key)"
   3.954 -                    }
   3.955 -                    ${Log}::error "TLS connection error: $errorMsg"
   3.956 -                    return 0
   3.957 -                }
   3.958 -            }
   3.959 -        }
   3.960 -    }
   3.961 -}
   3.962 -
   3.963 -proc ::relmon::update::main {args} {
   3.964 -    variable Config
   3.965 -    variable usage
   3.966 -    variable Statistics
   3.967 -    variable Watchlist [dict create]
   3.968 -    variable Queue [dict create]
   3.969 -    variable HostConnections [dict create]
   3.970 -    variable HostDelays [dict create]
   3.971 -    variable ActiveTransfers [dict create]
   3.972 -    variable State
   3.973 -    variable StateBuffer [dict create]
   3.974 -    variable PreprocessedHtmlBuffer
   3.975 -    variable Log
   3.976 -    variable Lf ""
   3.977 -    variable ExitStatus
   3.978 -
   3.979 -    # parse commandline
   3.980 -    while {[set GetoptRet [cmdline::getopt args \
   3.981 -            {c.arg C.arg d D.arg e H.arg i.arg l.arg r.arg t.arg T.arg v} \
   3.982 -            OptArg OptVal]] == 1} {
   3.983 -        switch -glob -- $OptArg {
   3.984 -            {c} {
   3.985 -                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
   3.986 -                    puts stderr "invalid value passed to \"-$OptArg\""
   3.987 -                    exit 1
   3.988 -                }
   3.989 -                dict set Config "host_connection_limit" $OptVal
   3.990 -            }
   3.991 -            {C} {
   3.992 -                if {![file isdirectory $OptVal]} {
   3.993 -                    puts stderr "directory \"$OptVal\" is not a directory"
   3.994 -                    exit 1
   3.995 -                } elseif {![file readable $OptVal] ||
   3.996 -                        ![file executable $OptVal]} {
   3.997 -                    puts stderr "directory \"$OptVal\" is not readable"
   3.998 -                    exit 1
   3.999 -                }
  3.1000 -                dict set Config "ca_dir" $OptVal
  3.1001 -            }
  3.1002 -            {d} {
  3.1003 -                dict set Config "log_level" "debug"
  3.1004 -            }
  3.1005 -            {D} {
  3.1006 -                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
  3.1007 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1008 -                    exit 1
  3.1009 -                }
  3.1010 -                dict set Config "host_delay" [expr {$OptVal * 1000}]
  3.1011 -            }
  3.1012 -            {e} {
  3.1013 -                dict set Config "error_filter" 1
  3.1014 -            }
  3.1015 -            {H} {
  3.1016 -                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
  3.1017 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1018 -                    exit 1
  3.1019 -                }
  3.1020 -                dict set Config "connection_limit" $OptVal
  3.1021 -            }
  3.1022 -            {i} {
  3.1023 -                foreach item [split $OptVal " "] {
  3.1024 -                    set item [string trim $item]
  3.1025 -                    if {$item ne ""} {
  3.1026 -                        dict lappend Config "item_filter" $item
  3.1027 -                    }
  3.1028 -                }
  3.1029 -            }
  3.1030 -            {l} {
  3.1031 -                dict set Config "log_file" $OptVal
  3.1032 -                set LogDir [file dirname $OptVal]
  3.1033 -                if {![file writable $LogDir] || ![file executable $LogDir]} {
  3.1034 -                    puts stderr "directory \"$LogDir\" is not writable"
  3.1035 -                    exit 1
  3.1036 -                }
  3.1037 -            }
  3.1038 -            {r} {
  3.1039 -                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
  3.1040 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1041 -                    exit 1
  3.1042 -                }
  3.1043 -                dict set Config "retry_limit" $OptVal
  3.1044 -            }
  3.1045 -            {t} {
  3.1046 -                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
  3.1047 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1048 -                    exit 1
  3.1049 -                }
  3.1050 -                dict set Config "timestamp_filter" [expr {$OptVal * 1000}]
  3.1051 -            }
  3.1052 -            {T} {
  3.1053 -                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
  3.1054 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1055 -                    exit 1
  3.1056 -                }
  3.1057 -                dict set Config "transfer_time_limit" [expr {$OptVal * 1000}]
  3.1058 -            }
  3.1059 -            {v} {
  3.1060 -                if {[dict get $Config "log_level"] ne "debug"} {
  3.1061 -                    dict set Config "log_level" "info"
  3.1062 -                }
  3.1063 -            }
  3.1064 -        }
  3.1065 -    }
  3.1066 -    set argc [llength $args]
  3.1067 -    if {$GetoptRet == -1} {
  3.1068 -        puts stderr "unknown command line option \"-$OptArg\""
  3.1069 -        puts stderr $usage
  3.1070 -        exit 1
  3.1071 -    }
  3.1072 -    if {$argc != 2} {
  3.1073 -        puts stderr $usage
  3.1074 -        exit 1
  3.1075 -    }
  3.1076 -    dict set Config "watchlist_file" [lindex $args 0]
  3.1077 -    if {![file readable [dict get $Config "watchlist_file"]]} {
  3.1078 -        puts stderr "watchlist file \"[dict get $Config "watchlist_file"]\"\
  3.1079 -                could not be read"
  3.1080 -        exit 1
  3.1081 -    }
  3.1082 -    set stateFile [lindex $args 1]
  3.1083 -    dict set Config "state_file" $stateFile
  3.1084 -    set StateDir [file dirname $stateFile]
  3.1085 -    if {![file writable $StateDir]} {
  3.1086 -        puts stderr "directory \"$StateDir\" is not writable"
  3.1087 -
  3.1088 -        exit 1
  3.1089 -    }
  3.1090 -
  3.1091 -    # install exit handler for closing the logfile, open the logfile and
  3.1092 -    # initialize logger
  3.1093 -    trace add execution exit enter CleanupBeforeExit
  3.1094 -    if {[dict get $Config "log_file"] ne ""} {
  3.1095 -        try {
  3.1096 -            set Lf [open [dict get $Config "log_file"] "w"]
  3.1097 -        } trap {POSIX} {errorMsg errorOptions} {
  3.1098 -            puts stderr "failed to open logfile\
  3.1099 -                    \"[dict get $Config "log_file"]\": $errorMsg"
  3.1100 -            exit 1
  3.1101 -        }
  3.1102 -    } else {
  3.1103 -        set Lf stderr
  3.1104 -    }
  3.1105 -    set Log [logger::init global]
  3.1106 -    if {[dict get $Config "log_level"] eq "debug"} {
  3.1107 -        set logFormat {%d \[%p\] \[%M\] %m}
  3.1108 -    } else {
  3.1109 -        set logFormat {%d \[%p\] %m}
  3.1110 -    }
  3.1111 -    logger::utils::applyAppender -appender fileAppend -appenderArgs \
  3.1112 -            [list -outputChannel $Lf -conversionPattern $logFormat] \
  3.1113 -            -serviceCmd $Log
  3.1114 -
  3.1115 -    # set default logging level
  3.1116 -    ${Log}::setlevel [dict get $Config "log_level"]
  3.1117 -
  3.1118 -    ${Log}::notice "relmon.tcl starting up"
  3.1119 -
  3.1120 -    # parse the watchlist
  3.1121 -    try {
  3.1122 -        ParseWatchlist [dict get $Config "watchlist_file"]
  3.1123 -    } trap {POSIX} {errorMsg errorOptions} - \
  3.1124 -    trap {RELMON} {errorMsg errorOptions} {
  3.1125 -        ${Log}::error $errorMsg
  3.1126 -        exit 1
  3.1127 -    }
  3.1128 -
  3.1129 -    # read the state file
  3.1130 -    try {
  3.1131 -        set State [::relmon::common::parseStateFile $stateFile]
  3.1132 -    } trap {POSIX ENOENT} {errorMsg} {
  3.1133 -        ${Log}::debug "state file \"$stateFile\" does not exist"
  3.1134 -        set State [dict create]
  3.1135 -    } trap {POSIX} {errorMsg} - \
  3.1136 -    trap {RELMON} {errorMsg} {
  3.1137 -        ${Log}::error $errorMsg
  3.1138 -        exit 1
  3.1139 -    }
  3.1140 -
  3.1141 -    # initialize queue and state buffer from the watchlist
  3.1142 -    dict set Statistics "start_time" [clock milliseconds]
  3.1143 -    dict for {name watchlistItem} $Watchlist {
  3.1144 -        # apply filters specified on the command line to watchlist items
  3.1145 -        if {([llength [dict get $Config "item_filter"]] > 0) &&
  3.1146 -                ($name ni [dict get $Config "item_filter"])} {
  3.1147 -            continue
  3.1148 -        }
  3.1149 -
  3.1150 -        if {[dict get $Config "error_filter"] &&
  3.1151 -                [dict exists $State $name "errors"] &&
  3.1152 -                ([llength [dict get $State $name "errors"]] == 0)} {
  3.1153 -            continue
  3.1154 -        }
  3.1155 -
  3.1156 -        if {[dict exists $State $name "timestamp"] &&
  3.1157 -                ([dict get $State $name "timestamp"] >
  3.1158 -                [dict get $Statistics "start_time"] -
  3.1159 -                [dict get $Config "timestamp_filter"])} {
  3.1160 -            continue
  3.1161 -        }
  3.1162 -
  3.1163 -        dict lappend Queue [::relmon::common::urlGetHost \
  3.1164 -                [dict get $watchlistItem "base_url"]] \
  3.1165 -                [dict create \
  3.1166 -                "name" $name \
  3.1167 -                "url" [dict get $watchlistItem "base_url"] \
  3.1168 -                "pattern_index" 0 \
  3.1169 -                "content_type" "" \
  3.1170 -                "num_redirects" 0 \
  3.1171 -                "num_retries" 0]
  3.1172 -        dict incr Statistics "items"
  3.1173 -        dict set StateBuffer $name [dict create "versions" [dict create] \
  3.1174 -                "errors" [list]]
  3.1175 -    }
  3.1176 -
  3.1177 -    # configure http and tls
  3.1178 -    http::register https 443 [list tls::socket \
  3.1179 -            -cadir [dict get $Config "ca_dir"] -request 1 -require 1 \
  3.1180 -            -command [namespace code OnTlsHandshake] -ssl2 0 -ssl3 1 -tls1 1]
  3.1181 -    http::config -useragent "Mozilla/5.0 (Windows NT 6.1; rv:16.0)\
  3.1182 -            Gecko/20100101 Firefox/16.0 relmon/$relmon::VERSION"
  3.1183 -
  3.1184 -    # handle errors while in the event loop
  3.1185 -    interp bgerror {} [namespace code OnError]
  3.1186 -
  3.1187 -    # enter the main loop
  3.1188 -    after idle [namespace code ManageTransfers]
  3.1189 -    vwait [namespace which -variable ExitStatus]
  3.1190 -
  3.1191 -    dict set Statistics "end_time" [clock milliseconds]
  3.1192 -
  3.1193 -    # display statistics
  3.1194 -    ${Log}::notice "items checked: [dict get $Statistics "items"]"
  3.1195 -    ${Log}::notice "time elapsed: [expr {([dict get $Statistics "end_time"] -
  3.1196 -        [dict get $Statistics "start_time"]) / 1000}]s"
  3.1197 -
  3.1198 -    # serialize the new state
  3.1199 -    set JsonStateItems {}
  3.1200 -    dict for {item data} $State {
  3.1201 -        set versions {}
  3.1202 -        dict for {version url} [dict get $data "versions"] {
  3.1203 -            lappend versions $version [json::write string $url]
  3.1204 -        }
  3.1205 -        set history {}
  3.1206 -        foreach historyItem [dict get $data "history"] {
  3.1207 -            lassign $historyItem version timestamp
  3.1208 -            lappend history [json::write array [json::write string $version] \
  3.1209 -                    $timestamp]
  3.1210 -        }
  3.1211 -        set errors {}
  3.1212 -        foreach errorItem [dict get $data "errors"] {
  3.1213 -            lappend errors [json::write string $errorItem]
  3.1214 -        }
  3.1215 -        lappend JsonStateItems $item [json::write object \
  3.1216 -            "versions" [json::write object {*}$versions] \
  3.1217 -            "history" [json::write array {*}$history] \
  3.1218 -            "timestamp" [dict get $data "timestamp"] \
  3.1219 -            "errors" [json::write array {*}$errors]]
  3.1220 -    }
  3.1221 -    set JsonState [json::write object {*}$JsonStateItems]
  3.1222 -
  3.1223 -    # try to preserve permissions and ownership
  3.1224 -    try {
  3.1225 -        set stateFileAttributes [file attributes $stateFile]
  3.1226 -    } trap {POSIX ENOENT} {} {
  3.1227 -        set stateFileAttributes {}
  3.1228 -    } trap {POSIX} {errorMsg errorOptions} {
  3.1229 -        ${Log}::error "failed to stat \"$stateFile\": $errorMsg"
  3.1230 -    }
  3.1231 -    # write the new state to a temporary file
  3.1232 -    set tmpFile "$stateFile.[pid].tmp"
  3.1233 -    try {
  3.1234 -        set f [open $tmpFile {RDWR CREAT EXCL TRUNC} 0600]
  3.1235 -    } trap {POSIX} {errorMsg errorOptions} {
  3.1236 -        ${Log}::error "failed to open \"$tmpFile\": $errorMsg"
  3.1237 -
  3.1238 -        exit 1
  3.1239 -    }
  3.1240 -    try {
  3.1241 -        chan puts -nonewline $f $JsonState
  3.1242 -    } trap {POSIX} {errorMsg errorOptions} {
  3.1243 -        catch {file delete $tmpFile}
  3.1244 -
  3.1245 -        ${Log}::error "failed to write to \"$tmpFile\": $errorMsg"
  3.1246 -
  3.1247 -        exit 1
  3.1248 -    } finally {
  3.1249 -        close $f
  3.1250 -    }
  3.1251 -    # make a backup of the previous state file
  3.1252 -    try {
  3.1253 -        file copy -force $stateFile "$stateFile~"
  3.1254 -    } trap {POSIX ENOENT} {} {
  3.1255 -        # ignore non-existing file
  3.1256 -    } trap {POSIX} {errorMsg errorOptions} {
  3.1257 -        ${Log}::error "failed to create a backup of \"$statFile\":\
  3.1258 -                $errorMsg"
  3.1259 -    }
  3.1260 -    # rename the temporary file to the state file name
  3.1261 -    try {
  3.1262 -        file rename -force $tmpFile $stateFile
  3.1263 -    } trap {POSIX} {errorMsg errorOptions} {
  3.1264 -        catch {file delete $tmpFile}
  3.1265 -
  3.1266 -        ${Log}::error "failed to rename \"$tmpFile\" to \"$stateFile\":\
  3.1267 -                $errorMsg"
  3.1268 -
  3.1269 -        exit 1
  3.1270 -    }
  3.1271 -    # restore ownership and permissions
  3.1272 -    try {
  3.1273 -        file attributes $stateFile {*}$stateFileAttributes
  3.1274 -    } trap {POSIX} {errorMsg errorOptions} {
  3.1275 -        ${Log}::error "failed to set permissions and ownership on\
  3.1276 -                \"$stateFile\": $errorMsg"
  3.1277 -
  3.1278 -        exit 1
  3.1279 -    }
  3.1280 -
  3.1281 -    # clean up
  3.1282 -    ${Log}::delete
  3.1283 -
  3.1284 -    exit $ExitStatus
  3.1285 -}
  3.1286 -
  3.1287 -
  3.1288 -namespace eval ::relmon::show {
  3.1289 -    # commandline option help text
  3.1290 -    variable usage "usage: relmon show statefile name..."
  3.1291 -}
  3.1292 -
  3.1293 -proc ::relmon::show::GetItem {stateName name} {
  3.1294 -    upvar 1 $stateName state
  3.1295 -    set item [dict get $state $name]
  3.1296 -
  3.1297 -    # format state data as plain-text
  3.1298 -    set output ""
  3.1299 -    append output "Name: $name\n"
  3.1300 -    append output "Latest Version:\
  3.1301 -            [lindex [lindex [dict get $item "history"] end] 0]\n"
  3.1302 -    append output "Refreshed: [clock format \
  3.1303 -            [expr {[dict get $item "timestamp"] / 1000}] \
  3.1304 -            -format {%Y-%m-%dT%H:%M:%S%z}]\n"
  3.1305 -    append output "Versions:\n"
  3.1306 -    dict for {version url} [dict get $item "versions"] {
  3.1307 -        append output "\t$version $url\n"
  3.1308 -    }
  3.1309 -    append output "Errors:\n"
  3.1310 -    if {[dict get $item "errors"] eq ""} {
  3.1311 -        append output "\tNone\n"
  3.1312 -    } else {
  3.1313 -        foreach errorMsg [dict get $item "errors"] {
  3.1314 -            append output "\t[string map {\n \n\t} [string trim $errorMsg]]\n"
  3.1315 -        }
  3.1316 -    }
  3.1317 -    append output "History:\n"
  3.1318 -    foreach historyItem [dict get $item "history"] {
  3.1319 -        append output "\t[lindex $historyItem 0] [clock format \
  3.1320 -                [expr {[lindex $historyItem 1] / 1000}] \
  3.1321 -                -format {%Y-%m-%dT%H:%M:%S%z}]\n"
  3.1322 -    }
  3.1323 -    return $output
  3.1324 -}
  3.1325 -
  3.1326 -proc ::relmon::show::main {args} {
  3.1327 -    variable usage
  3.1328 -
  3.1329 -    # parse commandline
  3.1330 -    if {[cmdline::getopt args {} OptArg OptVal] == -1} {
  3.1331 -        puts stderr "unknown command line option \"-$OptArg\""
  3.1332 -        puts stderr $usage
  3.1333 -        exit 1
  3.1334 -    }
  3.1335 -    if {[llength $args] < 2} {
  3.1336 -        puts stderr $usage
  3.1337 -        exit 1
  3.1338 -    }
  3.1339 -    set stateFile [lindex $args 0]
  3.1340 -    set names [lrange $args 1 end]
  3.1341 -
  3.1342 -    try {
  3.1343 -        set state [::relmon::common::parseStateFile $stateFile]
  3.1344 -    } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
  3.1345 -        puts stderr $errorMsg
  3.1346 -        exit 1
  3.1347 -    }
  3.1348 -
  3.1349 -    # show each item
  3.1350 -    foreach name $names {
  3.1351 -        puts -nonewline [GetItem state $name]
  3.1352 -    }
  3.1353 -
  3.1354 -    exit 0
  3.1355 -}
  3.1356 -
  3.1357 -
  3.1358 -namespace eval ::relmon::list {
  3.1359 -    # commandline option help text
  3.1360 -    variable usage "usage: relmon list \[-H\] \[-f html|parseable|text\]\
  3.1361 -            \[-F url\]\n\
  3.1362 -            \                  \[-n number_items\] statefile\n\
  3.1363 -            \      relmon list -f atom -F url \[-n number_items\] statefile"
  3.1364 -
  3.1365 -    # configuration options
  3.1366 -    variable Config [dict create \
  3.1367 -            "format" "text" \
  3.1368 -            "show_history" 0 \
  3.1369 -            "history_limit" 100 \
  3.1370 -            "feed_url" ""]
  3.1371 -}
  3.1372 -
  3.1373 -proc ::relmon::list::FormatText {stateName includeHistory historyLimit} {
  3.1374 -    upvar 1 $stateName state
  3.1375 -    set output ""
  3.1376 -    append output [format "%-35s %-15s %-24s %-3s\n" "Project" "Version" \
  3.1377 -            "Refreshed" "St."]
  3.1378 -    append output [string repeat "-" 80]
  3.1379 -    append output "\n"
  3.1380 -
  3.1381 -    set history {}
  3.1382 -    dict for {name item} $state {
  3.1383 -        foreach historyItem [dict get $item "history"] {
  3.1384 -            lappend history [list [lindex $historyItem 1] $name \
  3.1385 -                    [lindex $historyItem 0]]
  3.1386 -        }
  3.1387 -        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
  3.1388 -        set timestamp [clock format [expr {[dict get $item "timestamp"] /
  3.1389 -                1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
  3.1390 -        set status [expr {[llength [dict get $item "errors"]] > 0 ? "E" : ""}]
  3.1391 -        append output [format "%-35s %15s %-24s %-1s\n" $name $latestVersion \
  3.1392 -                $timestamp $status]
  3.1393 -    }
  3.1394 -    if {$includeHistory} {
  3.1395 -        append output "\nHistory\n"
  3.1396 -        append output [string repeat "-" 80]
  3.1397 -        append output "\n"
  3.1398 -        set history [lsort -decreasing -integer -index 0 $history]
  3.1399 -        foreach historyItem [lrange $history 0 $historyLimit] {
  3.1400 -            append output [format "%-24s %-35s %15s\n" \
  3.1401 -                    [clock format [expr {[lindex $historyItem 0] / 1000}] \
  3.1402 -                    -format {%Y-%m-%dT%H:%M:%S%z}] [lindex $historyItem 1] \
  3.1403 -                    [lindex $historyItem 2]]
  3.1404 -        }
  3.1405 -    }
  3.1406 -
  3.1407 -    return $output
  3.1408 -}
  3.1409 -
  3.1410 -proc ::relmon::list::FormatParseable {stateName includeHistory historyLimit} {
  3.1411 -    upvar 1 $stateName state
  3.1412 -    set output ""
  3.1413 -    set history {}
  3.1414 -    dict for {name item} $state {
  3.1415 -        foreach historyItem [dict get $item "history"] {
  3.1416 -            lappend history [list [lindex $historyItem 1] $name \
  3.1417 -                    [lindex $historyItem 0]]
  3.1418 -        }
  3.1419 -        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
  3.1420 -        if {$latestVersion eq ""} {
  3.1421 -            set latestVersion -
  3.1422 -        }
  3.1423 -        set timestamp [clock format [expr {[dict get $item "timestamp"] /
  3.1424 -                1000}] -timezone :UTC -format {%Y-%m-%dT%H:%M:%SZ}]
  3.1425 -        set status [expr {[llength [dict get $item "errors"]] > 0 ? "ERROR" :
  3.1426 -                "OK"}]
  3.1427 -        append output [format "%s\t%s\t%s\t%s\n" $name $latestVersion \
  3.1428 -                $timestamp $status]
  3.1429 -    }
  3.1430 -    if {$includeHistory} {
  3.1431 -        append output "\n"
  3.1432 -        set history [lsort -decreasing -integer -index 0 $history]
  3.1433 -        foreach historyItem [lrange $history 0 $historyLimit] {
  3.1434 -            append output [format "%s\t%s\t%s\n" [clock format \
  3.1435 -                    [expr {[lindex $historyItem 0] / 1000}] -timezone :UTC \
  3.1436 -                    -format {%Y-%m-%dT%H:%M:%SZ}] [lindex $historyItem 1] \
  3.1437 -                    [lindex $historyItem 2]]
  3.1438 -        }
  3.1439 -    }
  3.1440 -    return $output
  3.1441 -}
  3.1442 -
  3.1443 -proc ::relmon::list::FormatHtml {stateName includeHistory historyLimit
  3.1444 -        feedUrl} {
  3.1445 -    upvar 1 $stateName state
  3.1446 -
  3.1447 -    set output "<html>\n"
  3.1448 -    append output "<head>\n"
  3.1449 -    append output "<title>Current Releases</title>\n"
  3.1450 -    if {$feedUrl ne ""} {
  3.1451 -        append output "<link type=\"application/atom+xml\" rel=\"alternate\"\
  3.1452 -                title=\"Release History\"\
  3.1453 -                href=\"[html::html_entities $feedUrl]\"/>\n"
  3.1454 -    }
  3.1455 -    append output "</head>\n"
  3.1456 -    append output "<body>\n"
  3.1457 -    append output "<h1>Current Releases</h1>\n<table>\n<tr>\n<th>Project</th>\
  3.1458 -            \n<th>Version</th>\n<th>Refreshed</th>\n<th>Status</th>\n</tr>\n"
  3.1459 -    set history {}
  3.1460 -    dict for {name item} $state {
  3.1461 -        foreach historyItem [dict get $item "history"] {
  3.1462 -            lappend history [list [lindex $historyItem 1] $name \
  3.1463 -                    [lindex $historyItem 0]]
  3.1464 -        }
  3.1465 -        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
  3.1466 -        set timestamp [clock format [expr {[dict get $item "timestamp"] /
  3.1467 -                1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
  3.1468 -        set status [expr {[llength [dict get $item "errors"]] > 0 ? "Error" :
  3.1469 -                "OK"}]
  3.1470 -
  3.1471 -        append output "<tr>\n<td>[html::html_entities $name]</td>\n"
  3.1472 -        if {$latestVersion ne ""} {
  3.1473 -            if {[dict exists $item "versions" $latestVersion]} {
  3.1474 -                set url [dict get $item "versions" $latestVersion]
  3.1475 -                append output "<td><a\
  3.1476 -                        href=\"[html::html_entities $url]\"\
  3.1477 -                        title=\"[html::html_entities\
  3.1478 -                        "$name $latestVersion"]\">[html::html_entities \
  3.1479 -                        $latestVersion]</a></td>\n"
  3.1480 -            } else {
  3.1481 -                append output "<td>[html::html_entities \
  3.1482 -                        $latestVersion]</td>\n"
  3.1483 -            }
  3.1484 -        } else {
  3.1485 -            append output "<td></td>\n"
  3.1486 -        }
  3.1487 -        append output "<td>$timestamp</td>\n"
  3.1488 -        append output "<td>[html::html_entities $status]</td>\n</tr>\n"
  3.1489 -    }
  3.1490 -    append output "</table>\n"
  3.1491 -
  3.1492 -    if {$includeHistory} {
  3.1493 -        set history [lsort -decreasing -integer -index 0 $history]
  3.1494 -        append output "<h1>Release History</h1>\n<table>\n"
  3.1495 -        append output "<tr><th>Time</th><th>Project</th><th>Version</th></tr>\n"
  3.1496 -        foreach historyItem [lrange $history 0 $historyLimit] {
  3.1497 -            set timestamp [clock format [expr {[lindex $historyItem 0] /
  3.1498 -                    1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
  3.1499 -            set name [lindex $historyItem 1]
  3.1500 -            set version [lindex $historyItem 2]
  3.1501 -            append output "<tr>\n<td>$timestamp</td>\n"
  3.1502 -            append output "<td>[html::html_entities $name]</td>\n"
  3.1503 -            append output "<td>[html::html_entities $version]</td></tr>\n"
  3.1504 -        }
  3.1505 -        append output "</table>\n"
  3.1506 -    }
  3.1507 -
  3.1508 -    append output "</body>\n</html>\n"
  3.1509 -
  3.1510 -    return $output
  3.1511 -}
  3.1512 -
  3.1513 -proc ::relmon::list::FormatAtom {stateName historyLimit feedUrl} {
  3.1514 -    upvar 1 $stateName state
  3.1515 -    set host [::relmon::common::urlGetHost $feedUrl]
  3.1516 -    set output "<?xml version=\"1.0\" encoding=\"utf-8\"?>\
  3.1517 -            \n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n"
  3.1518 -    append output "<author><name>relmon</name></author>\n"
  3.1519 -    append output "<title>Release History</title>\n"
  3.1520 -    append output "<id>[html::html_entities $feedUrl]</id>\n"
  3.1521 -    set history {}
  3.1522 -    dict for {name item} $state {
  3.1523 -        foreach historyItem [dict get $item "history"] {
  3.1524 -            lappend history [list [lindex $historyItem 1] $name \
  3.1525 -                    [lindex $historyItem 0]]
  3.1526 -        }
  3.1527 -    }
  3.1528 -    set history [lsort -decreasing -integer -index 0 $history]
  3.1529 -    set updated [lindex [lindex $history end] 0]
  3.1530 -    if {$updated eq ""} {
  3.1531 -        set updated [clock seconds]
  3.1532 -    }
  3.1533 -    append output "<updated>[clock format $updated \
  3.1534 -            -format {%Y-%m-%dT%H:%M:%S%z}]</updated>\n"
  3.1535 -    foreach historyItem [lrange $history 0 $historyLimit] {
  3.1536 -        set name [lindex $historyItem 1]
  3.1537 -        set version [lindex $historyItem 2]
  3.1538 -        set timestamp [clock format [expr {[lindex $historyItem 0] / 1000}] \
  3.1539 -                -format {%Y-%m-%dT%H:%M:%S%z}]
  3.1540 -        set id "tag:$host,[clock format [lindex $historyItem 0] \
  3.1541 -                -format {%Y-%m-%d}]:[uri::urn::quote $name-$version]"
  3.1542 -        append output "<entry>\n"
  3.1543 -        append output "<id>[html::html_entities $id]</id>\n"
  3.1544 -        append output "<updated>$timestamp</updated>\n"
  3.1545 -        append output "<title>[html::html_entities "$name $version"]</title>"
  3.1546 -        append output "<content>[html::html_entities \
  3.1547 -                "$name $version"]</content>\n"
  3.1548 -        append output "</entry>\n"
  3.1549 -    }
  3.1550 -    append output "</feed>\n"
  3.1551 -    return $output
  3.1552 -}
  3.1553 -
  3.1554 -proc ::relmon::list::main {args} {
  3.1555 -    variable usage
  3.1556 -    variable Config
  3.1557 -
  3.1558 -    # parse commandline
  3.1559 -    while {[set GetoptRet [cmdline::getopt args {f.arg F.arg H n.arg} OptArg \
  3.1560 -            OptVal]] == 1} {
  3.1561 -        switch -glob -- $OptArg {
  3.1562 -            {f} {
  3.1563 -                if {$OptVal ni {atom html parseable text}} {
  3.1564 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1565 -                    exit 1
  3.1566 -                }
  3.1567 -                dict set Config "format" $OptVal
  3.1568 -            }
  3.1569 -            {F} {
  3.1570 -                if {[catch {dict create {*}[uri::split $OptVal]} UrlParts] ||
  3.1571 -                        ([dict get $UrlParts "host"] eq "")} {
  3.1572 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1573 -                    exit 1
  3.1574 -                }
  3.1575 -                dict set Config "feed_url" $OptVal
  3.1576 -            }
  3.1577 -            {H} {
  3.1578 -                dict set Config "show_history" 1
  3.1579 -            }
  3.1580 -            {n} {
  3.1581 -                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
  3.1582 -                    puts stderr "invalid value passed to \"-$OptArg\""
  3.1583 -                    exit 1
  3.1584 -                }
  3.1585 -                dict set Config "history_limit" [expr {$OptVal - 1}]
  3.1586 -            }
  3.1587 -        }
  3.1588 -    }
  3.1589 -    set argc [llength $args]
  3.1590 -    if {$GetoptRet == -1} {
  3.1591 -        puts stderr "unknown command line option \"-$OptArg\""
  3.1592 -        puts stderr $usage
  3.1593 -        exit 1
  3.1594 -    }
  3.1595 -    if {$argc != 1} {
  3.1596 -        puts stderr $usage
  3.1597 -        exit 1
  3.1598 -    }
  3.1599 -    if {([dict get $Config "format"] eq "atom") &&
  3.1600 -            ([dict get $Config "feed_url"] eq "")} {
  3.1601 -        puts stderr "mandatory \"-F\" option is missing"
  3.1602 -        puts stderr $usage
  3.1603 -        exit 1
  3.1604 -    }
  3.1605 -    set StateFile [lindex $args 0]
  3.1606 -
  3.1607 -    # read the state file
  3.1608 -    try {
  3.1609 -        set State [::relmon::common::parseStateFile $StateFile]
  3.1610 -    } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
  3.1611 -        puts stderr $errorMsg
  3.1612 -        exit 1
  3.1613 -    }
  3.1614 -
  3.1615 -    # call formatter
  3.1616 -    switch -- [dict get $Config "format"] {
  3.1617 -        {atom} {
  3.1618 -            puts -nonewline [FormatAtom State \
  3.1619 -                    [dict get $Config "history_limit"] \
  3.1620 -                    [dict get $Config "feed_url"]]
  3.1621 -        }
  3.1622 -        {html} {
  3.1623 -            puts -nonewline [FormatHtml State \
  3.1624 -                    [dict get $Config "show_history"] \
  3.1625 -                    [dict get $Config "history_limit"] \
  3.1626 -                    [dict get $Config "feed_url"]]
  3.1627 -        }
  3.1628 -        {parseable} {
  3.1629 -            puts -nonewline [FormatParseable State \
  3.1630 -                    [dict get $Config "show_history"] \
  3.1631 -                    [dict get $Config "history_limit"]]
  3.1632 -        }
  3.1633 -        {default} {
  3.1634 -            puts -nonewline [FormatText State \
  3.1635 -                    [dict get $Config "show_history"] \
  3.1636 -                    [dict get $Config "history_limit"]]
  3.1637 -        }
  3.1638 -    }
  3.1639 -
  3.1640 -    exit 0
  3.1641 -}
  3.1642 -
  3.1643 -
  3.1644 -namespace eval ::relmon::help {
  3.1645 -    # commandline option help text
  3.1646 -    variable usage "usage: relmon help \[subcommand\]"
  3.1647 -}
  3.1648 -
  3.1649 -proc ::relmon::help::main {args} {
  3.1650 -    variable usage
  3.1651 -
  3.1652 -    # parse commandline
  3.1653 -    if {[cmdline::getopt args {} OptArg OptVal] == -1} {
  3.1654 -        puts stderr "unknown command line option \"-$OptArg\""
  3.1655 -        puts stderr $usage
  3.1656 -        exit 1
  3.1657 -    }
  3.1658 -    set argc [llength $args]
  3.1659 -    if {$argc > 1} {
  3.1660 -        puts stderr $usage
  3.1661 -        exit 1
  3.1662 -    }
  3.1663 -    set subCommand [lindex $args 0]
  3.1664 -    if {$subCommand ne ""} {
  3.1665 -        if {[info procs ::relmon::${subCommand}::main] ne ""} {
  3.1666 -            puts stderr [set ::relmon::${subCommand}::usage]
  3.1667 -        } else {
  3.1668 -            puts stderr "unknown subcommand \"$subCommand\""
  3.1669 -            puts stderr $usage
  3.1670 -            exit 1
  3.1671 -        }
  3.1672 -    } else {
  3.1673 -        foreach subCommandNs [namespace children ::relmon] {
  3.1674 -            if {[info procs ${subCommandNs}::main] ne ""} {
  3.1675 -                puts stderr [set ${subCommandNs}::usage]
  3.1676 -            }
  3.1677 -        }
  3.1678 -    }
  3.1679 -    exit 0
  3.1680 -}
  3.1681 -
  3.1682 -
  3.1683 -proc ::relmon::main {args} {
  3.1684 -    variable usage
  3.1685 -    set subArgs [lassign $args subCommand]
  3.1686 -
  3.1687 -    # generate list of subcommands
  3.1688 -    set subCommands {}
  3.1689 -    foreach subCommandNs [namespace children ::relmon] {
  3.1690 -        if {[info procs ${subCommandNs}::main] ne ""} {
  3.1691 -            lappend subCommands [namespace tail $subCommandNs]
  3.1692 -        }
  3.1693 -    }
  3.1694 -    if {$subCommand ni $subCommands} {
  3.1695 -        if {$subCommand ne ""} {
  3.1696 -            puts stderr "unknown subcommand \"$subCommand\""
  3.1697 -        }
  3.1698 -        foreach command $subCommands {
  3.1699 -            puts stderr [set relmon::${command}::usage]
  3.1700 -        }
  3.1701 -        exit 1
  3.1702 -    }
  3.1703 -
  3.1704 -    # dispatch subcommand
  3.1705 -    relmon::${subCommand}::main {*}$subArgs
  3.1706 -}
  3.1707 -
  3.1708 -
  3.1709 -relmon::main {*}$argv
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/relmon.tcl.in	Mon Oct 20 19:31:20 2014 +0200
     4.3 @@ -0,0 +1,1706 @@
     4.4 +#!/usr/bin/tclsh
     4.5 +#
     4.6 +# Copyright (C) 2014 Guido Berhoerster <guido+relmon@berhoerster.name>
     4.7 +#
     4.8 +# Permission is hereby granted, free of charge, to any person obtaining
     4.9 +# a copy of this software and associated documentation files (the
    4.10 +# "Software"), to deal in the Software without restriction, including
    4.11 +# without limitation the rights to use, copy, modify, merge, publish,
    4.12 +# distribute, sublicense, and/or sell copies of the Software, and to
    4.13 +# permit persons to whom the Software is furnished to do so, subject to
    4.14 +# the following conditions:
    4.15 +#
    4.16 +# The above copyright notice and this permission notice shall be included
    4.17 +# in all copies or substantial portions of the Software.
    4.18 +#
    4.19 +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
    4.20 +# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
    4.21 +# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
    4.22 +# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
    4.23 +# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
    4.24 +# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
    4.25 +# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
    4.26 +
    4.27 +package require Tcl 8.5
    4.28 +package require http
    4.29 +package require tls
    4.30 +package require tdom
    4.31 +package require try
    4.32 +package require cmdline
    4.33 +package require control
    4.34 +package require html
    4.35 +package require htmlparse
    4.36 +package require json
    4.37 +package require json::write
    4.38 +package require logger
    4.39 +package require logger::utils
    4.40 +package require textutil::split
    4.41 +package require uri
    4.42 +package require uri::urn
    4.43 +
    4.44 +
    4.45 +namespace eval ::relmon {
    4.46 +    # version
    4.47 +    variable VERSION @VERSION@
    4.48 +}
    4.49 +
    4.50 +
    4.51 +namespace eval ::relmon::common {
    4.52 +    namespace export cmpVersions isUrlValid urlGetHost normalizeHttpHeaders \
    4.53 +            parseStateFile
    4.54 +}
    4.55 +
    4.56 +# implementation of the Debian version comparison algorithm described at
    4.57 +# http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version
    4.58 +proc ::relmon::common::cmpVersion {v1 v2} {
    4.59 +    set v1Len [string length $v1]
    4.60 +    set v2Len [string length $v2]
    4.61 +    set v1Pos 0
    4.62 +    set v2Pos 0
    4.63 +    while {($v1Pos < $v1Len) || ($v2Pos < $v2Len)} {
    4.64 +        set firstNumDiff 0
    4.65 +        # until reaching ASCII digits in both version strings compare character
    4.66 +        # values which are modified as so they are sorted in the following
    4.67 +        # order:
    4.68 +        # - "~"
    4.69 +        # - missing character or ASCII digits
    4.70 +        # - ASCII alphabet
    4.71 +        # - everything else in the order of their unicode value
    4.72 +        while {(($v1Pos < $v1Len) &&
    4.73 +                ![string match {[0123456789]} [string index $v1 $v1Pos]]) ||
    4.74 +                (($v2Pos < $v2Len) &&
    4.75 +                ![string match {[0123456789]} [string index $v2 $v2Pos]])} {
    4.76 +            foreach char [list [string index $v1 $v1Pos] \
    4.77 +                    [string index $v2 $v2Pos]] charValueName \
    4.78 +                    {v1CharValue v2CharValue} {
    4.79 +                if {$char eq "~"} {
    4.80 +                    set $charValueName -1
    4.81 +                } elseif {$char eq ""} {
    4.82 +                    set $charValueName 0
    4.83 +                } elseif {[string match {[0123456789]} $char]} {
    4.84 +                    set $charValueName 0
    4.85 +                } elseif {[string match -nocase {[abcdefghijklmnopqrstuvwxyz]} \
    4.86 +                        $char]} {
    4.87 +                    set $charValueName [scan $char "%c"]
    4.88 +                } else {
    4.89 +                    set $charValueName [expr {[scan $char "%c"] + 0x7f + 1}]
    4.90 +                }
    4.91 +            }
    4.92 +            if {$v1CharValue != $v2CharValue} {
    4.93 +                return [expr {$v1CharValue - $v2CharValue}]
    4.94 +            }
    4.95 +            incr v1Pos
    4.96 +            incr v2Pos
    4.97 +        }
    4.98 +
    4.99 +        # strip leading zeros
   4.100 +        while {[string index $v1 $v1Pos] eq "0"} {
   4.101 +            incr v1Pos
   4.102 +        }
   4.103 +        while {[string index $v2 $v2Pos] eq "0"} {
   4.104 +            incr v2Pos
   4.105 +        }
   4.106 +
   4.107 +        # process digits until reaching a non-digit
   4.108 +        while {[string match {[0123456789]} [string index $v1 $v1Pos]] &&
   4.109 +                [string match {[0123456789]} [string index $v2 $v2Pos]]} {
   4.110 +            # record the first difference between the two numbers
   4.111 +            if {$firstNumDiff == 0} {
   4.112 +                set firstNumDiff [expr {[string index $v1 $v1Pos] -
   4.113 +                        [string index $v2 $v2Pos]}]
   4.114 +            }
   4.115 +            incr v1Pos
   4.116 +            incr v2Pos
   4.117 +        }
   4.118 +
   4.119 +        # return if the number of one version has more digits than the other
   4.120 +        # since the one with more digits is the larger number
   4.121 +        if {[string match {[0123456789]} [string index $v1 $v1Pos]]} {
   4.122 +            return 1
   4.123 +        } elseif {[string match {[0123456789]} [string index $v2 $v2Pos]]} {
   4.124 +            return -1
   4.125 +        }
   4.126 +
   4.127 +        # return the difference if the digits differed above
   4.128 +        if {$firstNumDiff != 0} {
   4.129 +            return $firstNumDiff
   4.130 +        }
   4.131 +    }
   4.132 +
   4.133 +    return 0
   4.134 +}
   4.135 +
   4.136 +proc ::relmon::common::isUrlValid {url} {
   4.137 +    return [expr {![catch {dict create {*}[uri::split $url]} urlParts] &&
   4.138 +            ([dict get $urlParts "scheme"] in {"http" "https"}) &&
   4.139 +            ([dict get $urlParts "host"] ne "")}]
   4.140 +}
   4.141 +
   4.142 +proc ::relmon::common::urlGetHost {url} {
   4.143 +    return [expr {(![catch {dict create {*}[uri::split $url]} urlParts]) ?
   4.144 +                [dict get $urlParts "host"] : ""}]
   4.145 +}
   4.146 +
   4.147 +proc ::relmon::common::normalizeHttpHeaders {headers} {
   4.148 +    set httpHeaders [dict create]
   4.149 +    foreach {header value} $headers {
   4.150 +        set words {}
   4.151 +        foreach word [split $header "-"] {
   4.152 +            lappend words [string totitle $word]
   4.153 +        }
   4.154 +        dict set httpHeaders [join $words "-"] $value
   4.155 +    }
   4.156 +    return $httpHeaders
   4.157 +}
   4.158 +
   4.159 +proc ::relmon::common::parseStateFile {stateFile} {
   4.160 +    try {
   4.161 +        set f [open $stateFile "r"]
   4.162 +    } trap {POSIX} {errorMsg errorOptions} {
   4.163 +        return -options $errorOptions \
   4.164 +                "failed to open state file \"$stateFile\": $errorMsg"
   4.165 +    }
   4.166 +    try {
   4.167 +        set state [json::json2dict [chan read $f]]
   4.168 +    } trap {POSIX} {errorMsg errorOptions} {
   4.169 +        return -options $errorOptions \
   4.170 +                "failed to read from state file \"$stateFile\": $errorMsg"
   4.171 +    } on error {errorMsg errorOptions} {
   4.172 +        # the json package does not set an error code
   4.173 +        dict set errorOptions "-errorcode" {RELMON JSON_PARSE_ERROR}
   4.174 +        return -options $errorOptions \
   4.175 +                "failed to parse state file \"$stateFile\": $errorMsg"
   4.176 +    } finally {
   4.177 +        close $f
   4.178 +    }
   4.179 +
   4.180 +    return $state
   4.181 +}
   4.182 +
   4.183 +
   4.184 +namespace eval ::relmon::update {
   4.185 +    # commandline option help text
   4.186 +    variable usage "usage: relmon update \[-dev\] \[-c max_connections\] \[-C\
   4.187 +            ca_dir\] \[-D delay\]\n\
   4.188 +            \                    \[-H max_host_connections\] \[-i\
   4.189 +            item\[,...\]\] \[-l logfile\]\n\
   4.190 +            \                    \[-r retries\] \[-t min_time\] watchlist\
   4.191 +            statefile"
   4.192 +
   4.193 +    # configuration options
   4.194 +    variable Config [dict create \
   4.195 +            "log_file" "" \
   4.196 +            "log_level" "notice" \
   4.197 +            "history_limit" 20 \
   4.198 +            "connection_limit" 16 \
   4.199 +            "host_connection_limit" 4 \
   4.200 +            "transfer_time_limit" 60000 \
   4.201 +            "retry_limit" 3 \
   4.202 +            "host_delay" 0 \
   4.203 +            "timestamp_filter" 0 \
   4.204 +            "error_filter" 0 \
   4.205 +            "item_filter" {} \
   4.206 +            "ca_dir" "" \
   4.207 +            "state_file" "" \
   4.208 +            "watchlist_file" ""]
   4.209 +
   4.210 +    # exit status
   4.211 +    variable ExitStatus
   4.212 +
   4.213 +    # transfer statistics
   4.214 +    variable Statistics [dict create \
   4.215 +            "start_time" 0 \
   4.216 +            "end_time" 0 \
   4.217 +            "requests" 0 \
   4.218 +            "items" 0]
   4.219 +
   4.220 +    # watchlist
   4.221 +    variable Watchlist
   4.222 +
   4.223 +    # ID of a delayed run of ManageTransfers
   4.224 +    variable ManageTransfersId ""
   4.225 +
   4.226 +    # queue of pending transfers
   4.227 +    variable Queue
   4.228 +
   4.229 +    # number of active connections per host
   4.230 +    variable HostConnections
   4.231 +
   4.232 +    # delays before opening a new connection to a host
   4.233 +    variable HostDelays
   4.234 +
   4.235 +    # active transfers
   4.236 +    variable ActiveTransfers
   4.237 +
   4.238 +    # buffer for tracking the state of unfinished items
   4.239 +    variable StateBuffer
   4.240 +
   4.241 +    # buffer needed by htmlparse::parse for constructing the preprocessed HTML
   4.242 +    # document
   4.243 +    variable PreprocessedHtmlBuffer
   4.244 +
   4.245 +    # logger handle
   4.246 +    variable Log
   4.247 +
   4.248 +    # logfile handle
   4.249 +    variable Lf
   4.250 +}
   4.251 +
   4.252 +proc ::relmon::update::OnError {message returnOptions} {
   4.253 +    # internal error, abort
   4.254 +    puts stderr [dict get $returnOptions "-errorinfo"]
   4.255 +
   4.256 +    exit 1
   4.257 +}
   4.258 +
   4.259 +proc ::relmon::update::CleanupBeforeExit {commandString operation} {
   4.260 +    variable Lf
   4.261 +
   4.262 +    # close logfile
   4.263 +    if {($Lf ne "") && ($Lf ni {stdin stderr})} {
   4.264 +        close $Lf
   4.265 +        set Lf ""
   4.266 +    }
   4.267 +
   4.268 +    return
   4.269 +}
   4.270 +
   4.271 +proc ::relmon::update::ParseWatchlist {watchlistFilename} {
   4.272 +    variable Watchlist
   4.273 +
   4.274 +    set lineno 0
   4.275 +    set f [open $watchlistFilename "r"]
   4.276 +    try {
   4.277 +        while {[chan gets $f line] != -1} {
   4.278 +            set fields [textutil::split::splitx [string trim $line] {[\t ]+}]
   4.279 +            incr lineno
   4.280 +
   4.281 +            if {([llength $fields] == 0) ||
   4.282 +                    ([string index [lindex $fields 0] 0] eq "#")} {
   4.283 +                # skip empty lines and comments
   4.284 +                continue
   4.285 +            } elseif {[llength $fields] < 3} {
   4.286 +                # a line consists of a name, base URL and at least one
   4.287 +                # version-matching pattern
   4.288 +                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   4.289 +                        "syntax error in \"$watchlistFilename\" line $lineno"
   4.290 +            }
   4.291 +
   4.292 +            set patterns [lassign $fields name baseUrl]
   4.293 +
   4.294 +            # validate URL
   4.295 +            if {![::relmon::common::isUrlValid $baseUrl]} {
   4.296 +                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   4.297 +                        "syntax error in \"$watchlistFilename\" line $lineno:\
   4.298 +                        invalid base URL"
   4.299 +            }
   4.300 +
   4.301 +            # process patterns
   4.302 +            set processedPatterns {}
   4.303 +            set patternIndex 0
   4.304 +            foreach pattern $patterns {
   4.305 +                incr patternIndex
   4.306 +
   4.307 +                # make trailing slashes optional except in the last
   4.308 +                # version-matching pattern
   4.309 +                if {($patternIndex != [llength $patterns]) &&
   4.310 +                        ([string index $pattern end] eq "/")} {
   4.311 +                    append pattern {?}
   4.312 +                }
   4.313 +
   4.314 +                # ensure patterns are anchored to the end of the line
   4.315 +                if {[string index $pattern end] ne "$"} {
   4.316 +                    append pattern {$}
   4.317 +                }
   4.318 +
   4.319 +                # actually validate the regular expression
   4.320 +                try {
   4.321 +                    set reInfo [regexp -about -- $pattern ""]
   4.322 +                } on error {errorMsg} {
   4.323 +                    return -code error \
   4.324 +                            -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   4.325 +                            "error in \"$watchlistFilename\" line $lineno:\
   4.326 +                            $errorMsg"
   4.327 +                }
   4.328 +                lappend processedPatterns $pattern
   4.329 +            }
   4.330 +            if {[lindex $reInfo 0] < 1} {
   4.331 +                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
   4.332 +                        "syntax error in \"$watchlistFilename\" line $lineno:\
   4.333 +                        the last regular expression must contain at least one
   4.334 +                        capturing group"
   4.335 +            }
   4.336 +
   4.337 +            dict set Watchlist $name "base_url" $baseUrl
   4.338 +            dict set Watchlist $name "patterns" $processedPatterns
   4.339 +        }
   4.340 +    } finally {
   4.341 +        close $f
   4.342 +    }
   4.343 +
   4.344 +    return
   4.345 +}
   4.346 +
   4.347 +proc ::relmon::update::ProcessHtmlElement {tag slash param textBehindTheTag} {
   4.348 +    variable PreprocessedHtmlBuffer
   4.349 +
   4.350 +    # copy every "<a>" element into PreprocessedHtmlBuffer
   4.351 +    if {($slash eq "") && ([string tolower $tag] eq "a")} {
   4.352 +        append PreprocessedHtmlBuffer "<$tag $param></$tag>"
   4.353 +    }
   4.354 +
   4.355 +    return
   4.356 +}
   4.357 +
   4.358 +proc ::relmon::update::PreprocessHtml {bodyDataName} {
   4.359 +    upvar 1 $bodyDataName bodyData
   4.360 +    variable PreprocessedHtmlBuffer
   4.361 +
   4.362 +    # preprocess the document with htmlparse by constructing a new document
   4.363 +    # consisting only of found "<a>" elements which then can be fed into tdom
   4.364 +    # again; this is useful if parsing via tdom fails; however, htmlparse
   4.365 +    # should only be used as a last resort because it is just too limited, it
   4.366 +    # gets easily confused within "<script>" elements and lacks attribute
   4.367 +    # parsing
   4.368 +    set PreprocessedHtmlBuffer "<html><body>"
   4.369 +    htmlparse::parse -cmd [namespace code ProcessHtmlElement] $bodyData
   4.370 +    append PreprocessedHtmlBuffer "</body></html>"
   4.371 +}
   4.372 +
   4.373 +proc ::relmon::update::ExtractUrls {bodyDataName contentType baseUrl
   4.374 +        rePattern} {
   4.375 +    upvar 1 $bodyDataName bodyData
   4.376 +    set extractedUrls {}
   4.377 +    set resultUrls [dict create]
   4.378 +    # extract all URLs or URL fragments
   4.379 +    switch -- $contentType {
   4.380 +        {text/html} -
   4.381 +        {application/xhtml+xml} {
   4.382 +            # HTML/XHTML
   4.383 +            # if tdom parsing has failed or not found any "<a>" element,
   4.384 +            # preprocess the document with htmlparse and try again
   4.385 +            if {[catch {dom parse -html $bodyData} doc] ||
   4.386 +                    ([set rootElement [$doc documentElement]] eq "") ||
   4.387 +                    ([llength [set aElements \
   4.388 +                    [$rootElement selectNodes {descendant::a}]]] == 0)} {
   4.389 +                try {
   4.390 +                    set doc [dom parse -html [PreprocessHtml bodyData]]
   4.391 +                } on error {errorMsg errorOptions} {
   4.392 +                    dict set errorOptions "-errorcode" \
   4.393 +                            {RELMON TDOM_PARSE_ERROR}
   4.394 +                    return -options $errorOptions $errorMsg
   4.395 +                }
   4.396 +                set rootElement [$doc documentElement]
   4.397 +                set aElements [$rootElement selectNodes {descendant::a}]
   4.398 +            }
   4.399 +            foreach node $aElements {
   4.400 +                set href [$node getAttribute "href" ""]
   4.401 +                if {$href ne ""} {
   4.402 +                    lappend extractedUrls $href
   4.403 +                }
   4.404 +            }
   4.405 +            $doc delete
   4.406 +        }
   4.407 +        {application/rss+xml} {
   4.408 +            # RSS 2.0
   4.409 +            try {
   4.410 +                set doc [dom parse $bodyData]
   4.411 +            } on error {errorMsg errorOptions} {
   4.412 +                dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
   4.413 +                return -options $errorOptions $errorMsg
   4.414 +            }
   4.415 +            set rootElement [$doc documentElement]
   4.416 +            if {$rootElement ne ""} {
   4.417 +                foreach node [$rootElement selectNodes {descendant::link}] {
   4.418 +                    set linkText [$node text]
   4.419 +                    if {$linkText ne ""} {
   4.420 +                        lappend extractedUrls $linkText
   4.421 +                    }
   4.422 +                }
   4.423 +            }
   4.424 +            $doc delete
   4.425 +        }
   4.426 +        {application/atom+xml} {
   4.427 +            # Atom 1.0
   4.428 +            try {
   4.429 +                set doc [dom parse $bodyData]
   4.430 +            } on error {errorMsg errorOptions} {
   4.431 +                dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
   4.432 +                return -options $errorOptions $errorMsg
   4.433 +            }
   4.434 +            set rootElement [$doc documentElement]
   4.435 +            if {$rootElement ne ""} {
   4.436 +                foreach node [$rootElement selectNodes {descendant::link}] {
   4.437 +                    set href [$node getAttribute "href" ""]
   4.438 +                    if {$href ne ""} {
   4.439 +                        lappend extractedUrls $href
   4.440 +                    }
   4.441 +                }
   4.442 +            }
   4.443 +            $doc delete
   4.444 +        }
   4.445 +        {text/plain} {
   4.446 +            # plain text
   4.447 +            foreach line [split $bodyData "\n"] {
   4.448 +                if {$line ne ""} {
   4.449 +                    lappend extractedUrls $line
   4.450 +                }
   4.451 +            }
   4.452 +        }
   4.453 +        default {
   4.454 +            return -code error \
   4.455 +                    -errorcode {RELMON UNSUPPORTED_CONTENT_TYPE_ERROR} \
   4.456 +                    "unsupported content type \"$contentType\""
   4.457 +        }
   4.458 +    }
   4.459 +    foreach url $extractedUrls {
   4.460 +        set normalizedUrl [uri::canonicalize [uri::resolve $baseUrl $url]]
   4.461 +        dict set resultUrls $normalizedUrl \
   4.462 +                [expr {[regexp -line -- $rePattern $normalizedUrl] ? 1 : 0}]
   4.463 +    }
   4.464 +
   4.465 +    return $resultUrls
   4.466 +}
   4.467 +
   4.468 +proc ::relmon::update::StateItemAppendError {name logMsg} {
   4.469 +    variable StateBuffer
   4.470 +
   4.471 +    dict update StateBuffer $name stateItem {
   4.472 +        dict lappend stateItem "errors" $logMsg
   4.473 +    }
   4.474 +
   4.475 +    return
   4.476 +}
   4.477 +
   4.478 +proc ::relmon::update::HandleSuccessfulTransfer {item httpBodyName} {
   4.479 +    upvar 1 $httpBodyName httpBody
   4.480 +    variable Log
   4.481 +    variable StateBuffer
   4.482 +    variable Queue
   4.483 +    variable Watchlist
   4.484 +
   4.485 +    set name [dict get $item "name"]
   4.486 +    set url [dict get $item "url"]
   4.487 +    set patternIndex [dict get $item "pattern_index"]
   4.488 +    set pattern [lindex [dict get $Watchlist $name "patterns"] $patternIndex]
   4.489 +
   4.490 +    ${Log}::info "\"$name\": \"$url\": transfer finished"
   4.491 +
   4.492 +    # parse data
   4.493 +    try {
   4.494 +        set urls [ExtractUrls httpBody [dict get $item "content_type"] $url \
   4.495 +                $pattern]
   4.496 +    } trap {RELMON} {errorMsg} {
   4.497 +        # continue on tdom parsing errors or when receiving documents with an
   4.498 +        # unsupported content type
   4.499 +        set urls [dict create]
   4.500 +        set warningMsg "\"$name\": \"$url\": failed to parse data: $errorMsg"
   4.501 +        ${Log}::warn $warningMsg
   4.502 +        StateItemAppendError $name $warningMsg
   4.503 +    }
   4.504 +
   4.505 +    if {$patternIndex < ([llength \
   4.506 +            [dict get $Watchlist $name "patterns"]] - 1)} {
   4.507 +        # if this is not the last, version-matching pattern, queue matched URLs
   4.508 +        dict for {newUrl matched} $urls {
   4.509 +            if {$matched} {
   4.510 +                if {![::relmon::common::isUrlValid $newUrl]} {
   4.511 +                    ${Log}::debug "\"$name\": \"$url\": ignoring matched but\
   4.512 +                            invalid URL \"$newUrl\""
   4.513 +                    continue
   4.514 +                }
   4.515 +
   4.516 +                ${Log}::debug "\"$name\": \"$url\": queuing \"$newUrl\""
   4.517 +
   4.518 +                dict lappend Queue [::relmon::common::urlGetHost $newUrl] \
   4.519 +                        [dict create "name" $name "url" $newUrl \
   4.520 +                        "pattern_index" [expr {$patternIndex + 1}] \
   4.521 +                        "content_type" "" "num_redirects" 0 "num_retries" 0]
   4.522 +            } else {
   4.523 +                ${Log}::debug "\"$name\": \"$url\": ignoring \"$newUrl\""
   4.524 +            }
   4.525 +        }
   4.526 +    } else {
   4.527 +        # otherwise this branch has finished, try to extract the versions and
   4.528 +        # store them in the buffer
   4.529 +        dict for {finalUrl matched} $urls {
   4.530 +            if {$matched} {
   4.531 +                regexp -line -- $pattern $finalUrl -> version
   4.532 +                if {$version ne ""} {
   4.533 +                    ${Log}::debug "\"$name\": \"$url\": extracted version\
   4.534 +                            \"$version\" from \"$finalUrl\" found on\
   4.535 +                            \"$url\""
   4.536 +                    dict set StateBuffer $name "versions" $version $finalUrl
   4.537 +                } else {
   4.538 +                    ${og}::debug "\"$name\": \"$url\": could not extract a\
   4.539 +                            version from \"$finalUrl\""
   4.540 +                }
   4.541 +            } else {
   4.542 +                ${Log}::debug "\"$name\": \"$url\": ignoring \"$finalUrl\""
   4.543 +            }
   4.544 +        }
   4.545 +    }
   4.546 +
   4.547 +    return
   4.548 +}
   4.549 +
   4.550 +proc ::relmon::update::HandleRedirect {item httpCode httpHeaders} {
   4.551 +    variable Log
   4.552 +    variable Queue
   4.553 +
   4.554 +    set name [dict get $item "name"]
   4.555 +    set url [dict get $item "url"]
   4.556 +
   4.557 +    if {![dict exists $httpHeaders "Location"]} {
   4.558 +        # bail out in case of an invalid HTTP response
   4.559 +        set warningMsg "\"$name\": \"$url\": transfer failed: invalid HTTP\
   4.560 +                response"
   4.561 +        ${Log}::warn $warningMsg
   4.562 +        StateItemAppendError $name $warningMsg
   4.563 +        return
   4.564 +    }
   4.565 +    set location [dict get $httpHeaders "Location"]
   4.566 +
   4.567 +    # sanitize URL from Location header
   4.568 +    if {[uri::isrelative $location]} {
   4.569 +        set redirectUrl [uri::canonicalize [uri::resolve \
   4.570 +                $url $location]]
   4.571 +    } else {
   4.572 +        if {![::relmon::common::isUrlValid $location]} {
   4.573 +            # bail out in case of an invalid redirect URL
   4.574 +            set warningMsg "\"$name\": \"$url\": received invalid redirect URL\
   4.575 +                    \"$location\""
   4.576 +            ${Log}::warn $warningMsg
   4.577 +            StateItemAppendError $name $warningMsg
   4.578 +            return
   4.579 +        }
   4.580 +        set redirectUrl [uri::canonicalize $location]
   4.581 +    }
   4.582 +
   4.583 +    ${Log}::notice "\"$name\": \"$url\": received redirect to \"$redirectUrl\""
   4.584 +
   4.585 +    # handle up to 10 redirects by re-queuing the target URL
   4.586 +    if {[dict get $item "num_redirects"] < 10} {
   4.587 +        ${Log}::debug "\"$name\": \"$url\": queuing \"$redirectUrl\" due to\
   4.588 +                redirect"
   4.589 +
   4.590 +        dict lappend Queue [::relmon::common::urlGetHost $redirectUrl] \
   4.591 +                [dict replace $item "url" $redirectUrl "content_type" "" \
   4.592 +                "num_redirects" [expr {[dict get $item "num_redirects"] + 1}] \
   4.593 +                "num_retries" 0]
   4.594 +    } else {
   4.595 +        set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
   4.596 +                redirects"
   4.597 +        ${Log}::warn $warningMsg
   4.598 +        StateItemAppendError $name $warningMsg
   4.599 +    }
   4.600 +
   4.601 +    return
   4.602 +}
   4.603 +
   4.604 +proc ::relmon::update::HandleProtocolError {item httpCode} {
   4.605 +    variable Log
   4.606 +    set name [dict get $item "name"]
   4.607 +    set url [dict get $item "url"]
   4.608 +    set warningMsg "\"$name\": \"$url\": transfer failed: $httpCode"
   4.609 +    ${Log}::warn $warningMsg
   4.610 +    StateItemAppendError $name $warningMsg
   4.611 +    return
   4.612 +}
   4.613 +
   4.614 +proc ::relmon::update::HandleTimeoutReset {item} {
   4.615 +    variable Log
   4.616 +    variable Config
   4.617 +    variable Queue
   4.618 +    set name [dict get $item "name"]
   4.619 +    set url [dict get $item "url"]
   4.620 +
   4.621 +    # retry by re-queuing the target URL until reaching the limit
   4.622 +    if {[dict get $item "num_retries"] < [dict get $Config "retry_limit"]} {
   4.623 +        ${Log}::warn "\"$name\": \"$url\": connection timed out or was reset,\
   4.624 +                retrying"
   4.625 +        dict lappend Queue [::relmon::common::urlGetHost $url] \
   4.626 +                [dict replace $item \
   4.627 +                "num_retries" [expr {[dict get $item "num_retries"] + 1}]]
   4.628 +    } else {
   4.629 +        set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
   4.630 +                retries"
   4.631 +        ${Log}::warn $warningMsg
   4.632 +        StateItemAppendError $name $warningMsg
   4.633 +    }
   4.634 +
   4.635 +    return
   4.636 +}
   4.637 +
   4.638 +proc ::relmon::update::HandleConnectionError {item errorMsg} {
   4.639 +    variable Log
   4.640 +    set name [dict get $item "name"]
   4.641 +    set url [dict get $item "url"]
   4.642 +    set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
   4.643 +    ${Log}::warn $warningMsg
   4.644 +    StateItemAppendError $name $warningMsg
   4.645 +    return
   4.646 +}
   4.647 +
   4.648 +proc ::relmon::update::TransferCallbackWrapper {callbackCmd args} {
   4.649 +    # ensure that exceptions get raised, by default http catches all errors and
   4.650 +    # silently ignores them, see https://core.tcl.tk/tcl/tktview?name=1414262
   4.651 +    if {[catch {eval $callbackCmd $args} -> errorOptions]} {
   4.652 +        OnError [dict get $errorOptions "-errorinfo"] $errorOptions
   4.653 +    }
   4.654 +    return
   4.655 +}
   4.656 +
   4.657 +proc ::relmon::update::ManageTransfers {} {
   4.658 +    variable Config
   4.659 +    variable ManageTransfersId
   4.660 +    variable Queue
   4.661 +    variable HostConnections
   4.662 +    variable HostDelays
   4.663 +    variable ActiveTransfers
   4.664 +    variable ExitStatus
   4.665 +    variable Log
   4.666 +
   4.667 +    after cancel $ManageTransfersId
   4.668 +
   4.669 +    # try to initiate new transfers
   4.670 +    while {([dict size $ActiveTransfers] <
   4.671 +            [dict get $Config "connection_limit"]) &&
   4.672 +            ([dict size $Queue] > 0)} {
   4.673 +        # find URLs in the queue with a host for which we have not reached the
   4.674 +        # per-host connection limit yet and for which no delay is in effect
   4.675 +        set item {}
   4.676 +        dict for {host items} $Queue {
   4.677 +            set now [clock milliseconds]
   4.678 +
   4.679 +            if {![dict exists $HostConnections $host]} {
   4.680 +                dict set HostConnections $host 0
   4.681 +            }
   4.682 +
   4.683 +            if {![dict exists $HostDelays $host]} {
   4.684 +                dict set HostDelays $host $now
   4.685 +            }
   4.686 +
   4.687 +            if {([dict get $HostConnections $host] <
   4.688 +                    [dict get $Config "host_connection_limit"]) &&
   4.689 +                    ([dict get $HostDelays $host] <= $now)} {
   4.690 +                # pop item from the queue
   4.691 +                set items [lassign $items item]
   4.692 +                if {[llength $items] > 0} {
   4.693 +                    dict set Queue $host $items
   4.694 +                } else {
   4.695 +                    dict unset Queue $host
   4.696 +                }
   4.697 +
   4.698 +                dict incr HostConnections $host
   4.699 +                # set a random delay before the next connection to this host
   4.700 +                # can be made
   4.701 +                dict set HostDelays $host \
   4.702 +                        [expr {[clock milliseconds] + int((rand() + 0.5) *
   4.703 +                        [dict get $Config "host_delay"])}]
   4.704 +                break
   4.705 +            }
   4.706 +        }
   4.707 +        # if no item could be found, the per-host connection limit for all
   4.708 +        # queued URLs has been reached and no new transfers may be started
   4.709 +        # at this point
   4.710 +        if {$item eq {}} {
   4.711 +            break
   4.712 +        }
   4.713 +        # otherwise start a new transfer
   4.714 +        set url [dict get $item "url"]
   4.715 +        set name [dict get $item "name"]
   4.716 +        try {
   4.717 +            set token [http::geturl $url \
   4.718 +                    -timeout [dict get $Config "transfer_time_limit"] \
   4.719 +                    -progress [namespace code {TransferCallbackWrapper \
   4.720 +                    OnTransferProgress}] \
   4.721 +                    -command [namespace code {TransferCallbackWrapper \
   4.722 +                    OnTransferFinished}]]
   4.723 +        } on ok {} {
   4.724 +            dict set ActiveTransfers $token $item
   4.725 +
   4.726 +            ${Log}::info "\"$name\": \"$url\": starting transfer"
   4.727 +        } on error {errorMsg} {
   4.728 +            # an error occured during socket setup, e.g. a DNS lookup failure
   4.729 +            set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
   4.730 +            ${Log}::warn $warningMsg
   4.731 +            StateItemAppendError $name $warningMsg
   4.732 +        }
   4.733 +    }
   4.734 +
   4.735 +    # terminate the event loop if there are no remaining transfers
   4.736 +    if {([dict size $ActiveTransfers]) == 0 && ([dict size $Queue] == 0)} {
   4.737 +        set ExitStatus 0
   4.738 +        return
   4.739 +    }
   4.740 +
   4.741 +    # due to per-host connection limits and per-host delays the maximum number
   4.742 +    # of connections may not be reached although there are still items in the
   4.743 +    # queue, in this case schedule ManageTransfers again after the smallest of
   4.744 +    # the current per-host delays
   4.745 +    set delay 0
   4.746 +    if {([dict size $ActiveTransfers] <
   4.747 +            [dict get $Config "connection_limit"]) &&
   4.748 +            ([dict size $Queue] > 0)} {
   4.749 +        dict for {host items} $Queue {
   4.750 +            if {(![dict exists $HostConnections $host] ||
   4.751 +                    ([dict get $HostConnections $host] <
   4.752 +                    [dict get $Config "host_connection_limit"])) &&
   4.753 +                    ([dict exists $HostDelays $host] &&
   4.754 +                    ([dict get $HostDelays $host] > $now))} {
   4.755 +                set hostDelay [expr {[dict get $HostDelays $host] - $now + 1}]
   4.756 +                if {(($delay == 0) ||
   4.757 +                        ($hostDelay < $delay))} {
   4.758 +                    set delay $hostDelay
   4.759 +                }
   4.760 +            }
   4.761 +        }
   4.762 +        if {$delay > 0} {
   4.763 +            set ManageTransfersId \
   4.764 +                    [after $delay [namespace code ManageTransfers]]
   4.765 +        }
   4.766 +    }
   4.767 +
   4.768 +    return
   4.769 +}
   4.770 +
   4.771 +proc ::relmon::update::OnTransferProgress {token total current} {
   4.772 +    upvar #0 $token httpState
   4.773 +    variable ActiveTransfers
   4.774 +    variable Log
   4.775 +
   4.776 +    # try to determine content type and abort transfer if content type is not
   4.777 +    # one that can be parsed, this is primarily to prevent accidental downloads
   4.778 +    if {[dict get $ActiveTransfers $token "content_type"] eq ""} {
   4.779 +        set httpHeaders [relmon::common::normalizeHttpHeaders \
   4.780 +                $httpState(meta)]
   4.781 +
   4.782 +        if {[dict exists $httpHeaders "Content-Type"]} {
   4.783 +            set contentType [string trim [lindex [split \
   4.784 +                    [dict get $httpHeaders "Content-Type"] ";"] 0]]
   4.785 +            dict set ActiveTransfers $token "content_type" $contentType
   4.786 +            if {$contentType ni {"text/html" "application/xhtml+xml"
   4.787 +                    "application/atom+xml" "application/rss+xml"
   4.788 +                    "text/plain"}} {
   4.789 +                ${Log}::warn "\"[dict get $ActiveTransfers $token "name"]\":\
   4.790 +                        \"[dict get $ActiveTransfers $token "url"]\": content\
   4.791 +                        type \"$contentType\" is not acceptable"
   4.792 +                http::reset $token
   4.793 +            }
   4.794 +        }
   4.795 +    }
   4.796 +}
   4.797 +
   4.798 +proc ::relmon::update::OnTransferFinished {token} {
   4.799 +    upvar #0 $token httpState
   4.800 +    variable Config
   4.801 +    variable HostConnections
   4.802 +    variable Queue
   4.803 +    variable ActiveTransfers
   4.804 +    variable Statistics
   4.805 +    variable StateBuffer
   4.806 +    variable State
   4.807 +    variable Log
   4.808 +
   4.809 +    set item [dict get $ActiveTransfers $token]
   4.810 +    set name [dict get $item "name"]
   4.811 +    set host [relmon::common::urlGetHost [dict get $item "url"]]
   4.812 +
   4.813 +    # update list of per-host connections, and number of remaining transfers
   4.814 +    # for this item
   4.815 +    dict unset ActiveTransfers $token
   4.816 +    dict incr HostConnections $host -1
   4.817 +
   4.818 +    switch -- $httpState(status) {
   4.819 +        {ok} {
   4.820 +            # normalize headers
   4.821 +            set httpHeaders [relmon::common::normalizeHttpHeaders \
   4.822 +                    $httpState(meta)]
   4.823 +
   4.824 +            # try to determine content type
   4.825 +            if {([dict get $item "content_type"] eq "") &&
   4.826 +                    [dict exists $httpHeaders "Content-Type"]} {
   4.827 +                dict set item "content_type" [string trim [lindex [split \
   4.828 +                        [dict get $httpHeaders "Content-Type"] ";"] 0]]
   4.829 +            }
   4.830 +
   4.831 +            # dispatch based on HTTP status code
   4.832 +            set httpCode [http::ncode $token]
   4.833 +            switch -glob -- $httpCode {
   4.834 +                {30[12378]} {
   4.835 +                    HandleRedirect $item $httpCode $httpHeaders
   4.836 +                }
   4.837 +                {200} {
   4.838 +                    HandleSuccessfulTransfer $item httpState(body)
   4.839 +                }
   4.840 +                default {
   4.841 +                    HandleProtocolError $item $httpState(http)
   4.842 +                }
   4.843 +            }
   4.844 +        }
   4.845 +        {reset} {
   4.846 +            # aborted due to wrong content type
   4.847 +        }
   4.848 +        {eof} -
   4.849 +        {timeout} {
   4.850 +            # timeout or connection reset
   4.851 +            HandleTimeoutReset $item
   4.852 +        }
   4.853 +        {error} {
   4.854 +            # connection may have failed or been refused
   4.855 +            HandleConnectionError $item [lindex $httpState(error) 0]
   4.856 +        }
   4.857 +    }
   4.858 +
   4.859 +    # check if all transfers of this item are finished
   4.860 +    set itemFinished 1
   4.861 +    dict for {queueHost queueItems} $Queue {
   4.862 +        foreach queueItem $queueItems {
   4.863 +            if {[dict get $queueItem "name"] eq $name} {
   4.864 +                set itemFinished 0
   4.865 +            }
   4.866 +        }
   4.867 +    }
   4.868 +    dict for {activeToken activeItem} $ActiveTransfers {
   4.869 +        if {[dict get $activeItem "name"] eq $name} {
   4.870 +            set itemFinished 0
   4.871 +        }
   4.872 +    }
   4.873 +    if {$itemFinished} {
   4.874 +        set timestamp [clock milliseconds]
   4.875 +
   4.876 +        # create httpState item if it does not exist yet
   4.877 +        if {![dict exists $State $name]} {
   4.878 +            dict set State $name [dict create "versions" [dict create] \
   4.879 +                    "history" [list] "timestamp" 0 "errors" [list]]
   4.880 +        }
   4.881 +
   4.882 +        # if there are no versions, log an error message since something must
   4.883 +        # be wrong
   4.884 +        if {[llength [dict get $StateBuffer $name "versions"]] == 0} {
   4.885 +            set warningMsg "\"$name\": no versions found"
   4.886 +            ${Log}::warn $warningMsg
   4.887 +            StateItemAppendError $name $warningMsg
   4.888 +        }
   4.889 +
   4.890 +        # update httpState item
   4.891 +        dict set State $name "errors" [dict get $StateBuffer $name "errors"]
   4.892 +        dict set State $name "timestamp" $timestamp
   4.893 +        if {[llength [dict get $StateBuffer $name "errors"]] == 0} {
   4.894 +            # expire old history entries
   4.895 +            set history [lrange [dict get $State $name "history"] \
   4.896 +                    [expr {[llength [dict get $State $name "history"]] -
   4.897 +                    [dict get $Config "history_limit"] + 1}] end]
   4.898 +
   4.899 +            # add currently latest available version to history if it is either
   4.900 +            # newer than the previous one or if the previous one is no longer
   4.901 +            # available (e.g. if it has been removed or the watchlist pattern
   4.902 +            # has been changed)
   4.903 +            set prevLatestVersion [lindex $history end 0]
   4.904 +            set curLatestVersion [lindex \
   4.905 +                    [lsort -command ::relmon::common::cmpVersion \
   4.906 +                    [dict keys [dict get $StateBuffer $name "versions"]]] end]
   4.907 +            if {([::relmon::common::cmpVersion $curLatestVersion \
   4.908 +                    $prevLatestVersion] > 0) ||
   4.909 +                    ![dict exists $StateBuffer $name "versions" \
   4.910 +                    $prevLatestVersion]} {
   4.911 +                lappend history [list $curLatestVersion $timestamp]
   4.912 +                dict set State $name "history" $history
   4.913 +            }
   4.914 +            dict set State $name "versions" [dict get $StateBuffer $name \
   4.915 +                    "versions"]
   4.916 +        }
   4.917 +        dict unset StateBuffer $name
   4.918 +
   4.919 +        ${Log}::notice "progress: [dict size $StateBuffer]/[dict get \
   4.920 +                $Statistics "items"] items left"
   4.921 +    }
   4.922 +
   4.923 +    http::cleanup $token
   4.924 +
   4.925 +    ManageTransfers
   4.926 +
   4.927 +    return
   4.928 +}
   4.929 +
   4.930 +# control certificate verification and log errors during TLS handshake
   4.931 +proc ::relmon::update::OnTlsHandshake {type args} {
   4.932 +    variable Config
   4.933 +    variable Log
   4.934 +
   4.935 +    switch -- ${type} {
   4.936 +        {error} {
   4.937 +            lassign $args {} tlsErrorMsg
   4.938 +            ${Log}::error "TLS connection error: $tlsErrorMsg"
   4.939 +        }
   4.940 +        {verify} {
   4.941 +            lassign $args {} {} {} status tlsErrorMsg
   4.942 +            array set cert [lindex $args 2]
   4.943 +            if {$status == 0} {
   4.944 +                if {[dict get $Config "ca_dir"] eq ""} {
   4.945 +                    # do not verify certificates is ca-dir was not set
   4.946 +                    return 1
   4.947 +                } else {
   4.948 +                    set errorMsg "$tlsErrorMsg\nCertificate details:"
   4.949 +                    foreach {key description} {"serial" "Serial Number"
   4.950 +                            "issuer" "Issuer" "notBefore" "Not Valid Before"
   4.951 +                            "notAfter" "Not Valid After" "subject" "Subject"
   4.952 +                            "sha1_hash" "SHA1 Hash"} {
   4.953 +                        append errorMsg "\n$description: $cert($key)"
   4.954 +                    }
   4.955 +                    ${Log}::error "TLS connection error: $errorMsg"
   4.956 +                    return 0
   4.957 +                }
   4.958 +            }
   4.959 +        }
   4.960 +    }
   4.961 +}
   4.962 +
   4.963 +proc ::relmon::update::main {args} {
   4.964 +    variable Config
   4.965 +    variable usage
   4.966 +    variable Statistics
   4.967 +    variable Watchlist [dict create]
   4.968 +    variable Queue [dict create]
   4.969 +    variable HostConnections [dict create]
   4.970 +    variable HostDelays [dict create]
   4.971 +    variable ActiveTransfers [dict create]
   4.972 +    variable State
   4.973 +    variable StateBuffer [dict create]
   4.974 +    variable PreprocessedHtmlBuffer
   4.975 +    variable Log
   4.976 +    variable Lf ""
   4.977 +    variable ExitStatus
   4.978 +
   4.979 +    # parse commandline
   4.980 +    while {[set GetoptRet [cmdline::getopt args \
   4.981 +            {c.arg C.arg d D.arg e H.arg i.arg l.arg r.arg t.arg T.arg v} \
   4.982 +            OptArg OptVal]] == 1} {
   4.983 +        switch -glob -- $OptArg {
   4.984 +            {c} {
   4.985 +                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
   4.986 +                    puts stderr "invalid value passed to \"-$OptArg\""
   4.987 +                    exit 1
   4.988 +                }
   4.989 +                dict set Config "host_connection_limit" $OptVal
   4.990 +            }
   4.991 +            {C} {
   4.992 +                if {![file isdirectory $OptVal]} {
   4.993 +                    puts stderr "directory \"$OptVal\" is not a directory"
   4.994 +                    exit 1
   4.995 +                } elseif {![file readable $OptVal] ||
   4.996 +                        ![file executable $OptVal]} {
   4.997 +                    puts stderr "directory \"$OptVal\" is not readable"
   4.998 +                    exit 1
   4.999 +                }
  4.1000 +                dict set Config "ca_dir" $OptVal
  4.1001 +            }
  4.1002 +            {d} {
  4.1003 +                dict set Config "log_level" "debug"
  4.1004 +            }
  4.1005 +            {D} {
  4.1006 +                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
  4.1007 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1008 +                    exit 1
  4.1009 +                }
  4.1010 +                dict set Config "host_delay" [expr {$OptVal * 1000}]
  4.1011 +            }
  4.1012 +            {e} {
  4.1013 +                dict set Config "error_filter" 1
  4.1014 +            }
  4.1015 +            {H} {
  4.1016 +                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
  4.1017 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1018 +                    exit 1
  4.1019 +                }
  4.1020 +                dict set Config "connection_limit" $OptVal
  4.1021 +            }
  4.1022 +            {i} {
  4.1023 +                foreach item [split $OptVal " "] {
  4.1024 +                    set item [string trim $item]
  4.1025 +                    if {$item ne ""} {
  4.1026 +                        dict lappend Config "item_filter" $item
  4.1027 +                    }
  4.1028 +                }
  4.1029 +            }
  4.1030 +            {l} {
  4.1031 +                dict set Config "log_file" $OptVal
  4.1032 +                set LogDir [file dirname $OptVal]
  4.1033 +                if {![file writable $LogDir] || ![file executable $LogDir]} {
  4.1034 +                    puts stderr "directory \"$LogDir\" is not writable"
  4.1035 +                    exit 1
  4.1036 +                }
  4.1037 +            }
  4.1038 +            {r} {
  4.1039 +                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
  4.1040 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1041 +                    exit 1
  4.1042 +                }
  4.1043 +                dict set Config "retry_limit" $OptVal
  4.1044 +            }
  4.1045 +            {t} {
  4.1046 +                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
  4.1047 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1048 +                    exit 1
  4.1049 +                }
  4.1050 +                dict set Config "timestamp_filter" [expr {$OptVal * 1000}]
  4.1051 +            }
  4.1052 +            {T} {
  4.1053 +                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
  4.1054 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1055 +                    exit 1
  4.1056 +                }
  4.1057 +                dict set Config "transfer_time_limit" [expr {$OptVal * 1000}]
  4.1058 +            }
  4.1059 +            {v} {
  4.1060 +                if {[dict get $Config "log_level"] ne "debug"} {
  4.1061 +                    dict set Config "log_level" "info"
  4.1062 +                }
  4.1063 +            }
  4.1064 +        }
  4.1065 +    }
  4.1066 +    set argc [llength $args]
  4.1067 +    if {$GetoptRet == -1} {
  4.1068 +        puts stderr "unknown command line option \"-$OptArg\""
  4.1069 +        puts stderr $usage
  4.1070 +        exit 1
  4.1071 +    }
  4.1072 +    if {$argc != 2} {
  4.1073 +        puts stderr $usage
  4.1074 +        exit 1
  4.1075 +    }
  4.1076 +    dict set Config "watchlist_file" [lindex $args 0]
  4.1077 +    if {![file readable [dict get $Config "watchlist_file"]]} {
  4.1078 +        puts stderr "watchlist file \"[dict get $Config "watchlist_file"]\"\
  4.1079 +                could not be read"
  4.1080 +        exit 1
  4.1081 +    }
  4.1082 +    set stateFile [lindex $args 1]
  4.1083 +    dict set Config "state_file" $stateFile
  4.1084 +    set StateDir [file dirname $stateFile]
  4.1085 +    if {![file writable $StateDir]} {
  4.1086 +        puts stderr "directory \"$StateDir\" is not writable"
  4.1087 +
  4.1088 +        exit 1
  4.1089 +    }
  4.1090 +
  4.1091 +    # install exit handler for closing the logfile, open the logfile and
  4.1092 +    # initialize logger
  4.1093 +    trace add execution exit enter CleanupBeforeExit
  4.1094 +    if {[dict get $Config "log_file"] ne ""} {
  4.1095 +        try {
  4.1096 +            set Lf [open [dict get $Config "log_file"] "w"]
  4.1097 +        } trap {POSIX} {errorMsg errorOptions} {
  4.1098 +            puts stderr "failed to open logfile\
  4.1099 +                    \"[dict get $Config "log_file"]\": $errorMsg"
  4.1100 +            exit 1
  4.1101 +        }
  4.1102 +    } else {
  4.1103 +        set Lf stderr
  4.1104 +    }
  4.1105 +    set Log [logger::init global]
  4.1106 +    if {[dict get $Config "log_level"] eq "debug"} {
  4.1107 +        set logFormat {%d \[%p\] \[%M\] %m}
  4.1108 +    } else {
  4.1109 +        set logFormat {%d \[%p\] %m}
  4.1110 +    }
  4.1111 +    logger::utils::applyAppender -appender fileAppend -appenderArgs \
  4.1112 +            [list -outputChannel $Lf -conversionPattern $logFormat] \
  4.1113 +            -serviceCmd $Log
  4.1114 +
  4.1115 +    # set default logging level
  4.1116 +    ${Log}::setlevel [dict get $Config "log_level"]
  4.1117 +
  4.1118 +    ${Log}::notice "relmon.tcl starting up"
  4.1119 +
  4.1120 +    # parse the watchlist
  4.1121 +    try {
  4.1122 +        ParseWatchlist [dict get $Config "watchlist_file"]
  4.1123 +    } trap {POSIX} {errorMsg errorOptions} - \
  4.1124 +    trap {RELMON} {errorMsg errorOptions} {
  4.1125 +        ${Log}::error $errorMsg
  4.1126 +        exit 1
  4.1127 +    }
  4.1128 +
  4.1129 +    # read the state file
  4.1130 +    try {
  4.1131 +        set State [::relmon::common::parseStateFile $stateFile]
  4.1132 +    } trap {POSIX ENOENT} {errorMsg} {
  4.1133 +        ${Log}::debug "state file \"$stateFile\" does not exist"
  4.1134 +        set State [dict create]
  4.1135 +    } trap {POSIX} {errorMsg} - \
  4.1136 +    trap {RELMON} {errorMsg} {
  4.1137 +        ${Log}::error $errorMsg
  4.1138 +        exit 1
  4.1139 +    }
  4.1140 +
  4.1141 +    # initialize queue and state buffer from the watchlist
  4.1142 +    dict set Statistics "start_time" [clock milliseconds]
  4.1143 +    dict for {name watchlistItem} $Watchlist {
  4.1144 +        # apply filters specified on the command line to watchlist items
  4.1145 +        if {([llength [dict get $Config "item_filter"]] > 0) &&
  4.1146 +                ($name ni [dict get $Config "item_filter"])} {
  4.1147 +            continue
  4.1148 +        }
  4.1149 +
  4.1150 +        if {[dict get $Config "error_filter"] &&
  4.1151 +                [dict exists $State $name "errors"] &&
  4.1152 +                ([llength [dict get $State $name "errors"]] == 0)} {
  4.1153 +            continue
  4.1154 +        }
  4.1155 +
  4.1156 +        if {[dict exists $State $name "timestamp"] &&
  4.1157 +                ([dict get $State $name "timestamp"] >
  4.1158 +                [dict get $Statistics "start_time"] -
  4.1159 +                [dict get $Config "timestamp_filter"])} {
  4.1160 +            continue
  4.1161 +        }
  4.1162 +
  4.1163 +        dict lappend Queue [::relmon::common::urlGetHost \
  4.1164 +                [dict get $watchlistItem "base_url"]] \
  4.1165 +                [dict create \
  4.1166 +                "name" $name \
  4.1167 +                "url" [dict get $watchlistItem "base_url"] \
  4.1168 +                "pattern_index" 0 \
  4.1169 +                "content_type" "" \
  4.1170 +                "num_redirects" 0 \
  4.1171 +                "num_retries" 0]
  4.1172 +        dict incr Statistics "items"
  4.1173 +        dict set StateBuffer $name [dict create "versions" [dict create] \
  4.1174 +                "errors" [list]]
  4.1175 +    }
  4.1176 +
  4.1177 +    # configure http and tls
  4.1178 +    http::register https 443 [list tls::socket \
  4.1179 +            -cadir [dict get $Config "ca_dir"] -request 1 -require 1 \
  4.1180 +            -command [namespace code OnTlsHandshake] -ssl2 0 -ssl3 1 -tls1 1]
  4.1181 +    http::config -useragent "Mozilla/5.0 (Windows NT 6.1; rv:16.0)\
  4.1182 +            Gecko/20100101 Firefox/16.0 relmon/$relmon::VERSION"
  4.1183 +
  4.1184 +    # handle errors while in the event loop
  4.1185 +    interp bgerror {} [namespace code OnError]
  4.1186 +
  4.1187 +    # enter the main loop
  4.1188 +    after idle [namespace code ManageTransfers]
  4.1189 +    vwait [namespace which -variable ExitStatus]
  4.1190 +
  4.1191 +    dict set Statistics "end_time" [clock milliseconds]
  4.1192 +
  4.1193 +    # display statistics
  4.1194 +    ${Log}::notice "items checked: [dict get $Statistics "items"]"
  4.1195 +    ${Log}::notice "time elapsed: [expr {([dict get $Statistics "end_time"] -
  4.1196 +        [dict get $Statistics "start_time"]) / 1000}]s"
  4.1197 +
  4.1198 +    # serialize the new state
  4.1199 +    set JsonStateItems {}
  4.1200 +    dict for {item data} $State {
  4.1201 +        set versions {}
  4.1202 +        dict for {version url} [dict get $data "versions"] {
  4.1203 +            lappend versions $version [json::write string $url]
  4.1204 +        }
  4.1205 +        set history {}
  4.1206 +        foreach historyItem [dict get $data "history"] {
  4.1207 +            lassign $historyItem version timestamp
  4.1208 +            lappend history [json::write array [json::write string $version] \
  4.1209 +                    $timestamp]
  4.1210 +        }
  4.1211 +        set errors {}
  4.1212 +        foreach errorItem [dict get $data "errors"] {
  4.1213 +            lappend errors [json::write string $errorItem]
  4.1214 +        }
  4.1215 +        lappend JsonStateItems $item [json::write object \
  4.1216 +            "versions" [json::write object {*}$versions] \
  4.1217 +            "history" [json::write array {*}$history] \
  4.1218 +            "timestamp" [dict get $data "timestamp"] \
  4.1219 +            "errors" [json::write array {*}$errors]]
  4.1220 +    }
  4.1221 +    set JsonState [json::write object {*}$JsonStateItems]
  4.1222 +
  4.1223 +    # try to preserve permissions and ownership
  4.1224 +    try {
  4.1225 +        set stateFileAttributes [file attributes $stateFile]
  4.1226 +    } trap {POSIX ENOENT} {} {
  4.1227 +        set stateFileAttributes {}
  4.1228 +    } trap {POSIX} {errorMsg errorOptions} {
  4.1229 +        ${Log}::error "failed to stat \"$stateFile\": $errorMsg"
  4.1230 +    }
  4.1231 +    # write the new state to a temporary file
  4.1232 +    set tmpFile "$stateFile.[pid].tmp"
  4.1233 +    try {
  4.1234 +        set f [open $tmpFile {RDWR CREAT EXCL TRUNC} 0600]
  4.1235 +    } trap {POSIX} {errorMsg errorOptions} {
  4.1236 +        ${Log}::error "failed to open \"$tmpFile\": $errorMsg"
  4.1237 +
  4.1238 +        exit 1
  4.1239 +    }
  4.1240 +    try {
  4.1241 +        chan puts -nonewline $f $JsonState
  4.1242 +    } trap {POSIX} {errorMsg errorOptions} {
  4.1243 +        catch {file delete $tmpFile}
  4.1244 +
  4.1245 +        ${Log}::error "failed to write to \"$tmpFile\": $errorMsg"
  4.1246 +
  4.1247 +        exit 1
  4.1248 +    } finally {
  4.1249 +        close $f
  4.1250 +    }
  4.1251 +    # make a backup of the previous state file
  4.1252 +    try {
  4.1253 +        file copy -force $stateFile "$stateFile~"
  4.1254 +    } trap {POSIX ENOENT} {} {
  4.1255 +        # ignore non-existing file
  4.1256 +    } trap {POSIX} {errorMsg errorOptions} {
  4.1257 +        ${Log}::error "failed to create a backup of \"$statFile\":\
  4.1258 +                $errorMsg"
  4.1259 +    }
  4.1260 +    # rename the temporary file to the state file name
  4.1261 +    try {
  4.1262 +        file rename -force $tmpFile $stateFile
  4.1263 +    } trap {POSIX} {errorMsg errorOptions} {
  4.1264 +        catch {file delete $tmpFile}
  4.1265 +
  4.1266 +        ${Log}::error "failed to rename \"$tmpFile\" to \"$stateFile\":\
  4.1267 +                $errorMsg"
  4.1268 +
  4.1269 +        exit 1
  4.1270 +    }
  4.1271 +    # restore ownership and permissions
  4.1272 +    try {
  4.1273 +        file attributes $stateFile {*}$stateFileAttributes
  4.1274 +    } trap {POSIX} {errorMsg errorOptions} {
  4.1275 +        ${Log}::error "failed to set permissions and ownership on\
  4.1276 +                \"$stateFile\": $errorMsg"
  4.1277 +
  4.1278 +        exit 1
  4.1279 +    }
  4.1280 +
  4.1281 +    # clean up
  4.1282 +    ${Log}::delete
  4.1283 +
  4.1284 +    exit $ExitStatus
  4.1285 +}
  4.1286 +
  4.1287 +
  4.1288 +namespace eval ::relmon::show {
  4.1289 +    # commandline option help text
  4.1290 +    variable usage "usage: relmon show statefile name..."
  4.1291 +}
  4.1292 +
  4.1293 +proc ::relmon::show::GetItem {stateName name} {
  4.1294 +    upvar 1 $stateName state
  4.1295 +    set item [dict get $state $name]
  4.1296 +
  4.1297 +    # format state data as plain-text
  4.1298 +    set output ""
  4.1299 +    append output "Name: $name\n"
  4.1300 +    append output "Latest Version:\
  4.1301 +            [lindex [lindex [dict get $item "history"] end] 0]\n"
  4.1302 +    append output "Refreshed: [clock format \
  4.1303 +            [expr {[dict get $item "timestamp"] / 1000}] \
  4.1304 +            -format {%Y-%m-%dT%H:%M:%S%z}]\n"
  4.1305 +    append output "Versions:\n"
  4.1306 +    dict for {version url} [dict get $item "versions"] {
  4.1307 +        append output "\t$version $url\n"
  4.1308 +    }
  4.1309 +    append output "Errors:\n"
  4.1310 +    if {[dict get $item "errors"] eq ""} {
  4.1311 +        append output "\tNone\n"
  4.1312 +    } else {
  4.1313 +        foreach errorMsg [dict get $item "errors"] {
  4.1314 +            append output "\t[string map {\n \n\t} [string trim $errorMsg]]\n"
  4.1315 +        }
  4.1316 +    }
  4.1317 +    append output "History:\n"
  4.1318 +    foreach historyItem [dict get $item "history"] {
  4.1319 +        append output "\t[lindex $historyItem 0] [clock format \
  4.1320 +                [expr {[lindex $historyItem 1] / 1000}] \
  4.1321 +                -format {%Y-%m-%dT%H:%M:%S%z}]\n"
  4.1322 +    }
  4.1323 +    return $output
  4.1324 +}
  4.1325 +
  4.1326 +proc ::relmon::show::main {args} {
  4.1327 +    variable usage
  4.1328 +
  4.1329 +    # parse commandline
  4.1330 +    if {[cmdline::getopt args {} OptArg OptVal] == -1} {
  4.1331 +        puts stderr "unknown command line option \"-$OptArg\""
  4.1332 +        puts stderr $usage
  4.1333 +        exit 1
  4.1334 +    }
  4.1335 +    if {[llength $args] < 2} {
  4.1336 +        puts stderr $usage
  4.1337 +        exit 1
  4.1338 +    }
  4.1339 +    set stateFile [lindex $args 0]
  4.1340 +    set names [lrange $args 1 end]
  4.1341 +
  4.1342 +    try {
  4.1343 +        set state [::relmon::common::parseStateFile $stateFile]
  4.1344 +    } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
  4.1345 +        puts stderr $errorMsg
  4.1346 +        exit 1
  4.1347 +    }
  4.1348 +
  4.1349 +    # show each item
  4.1350 +    foreach name $names {
  4.1351 +        puts -nonewline [GetItem state $name]
  4.1352 +    }
  4.1353 +
  4.1354 +    exit 0
  4.1355 +}
  4.1356 +
  4.1357 +
  4.1358 +namespace eval ::relmon::list {
  4.1359 +    # commandline option help text
  4.1360 +    variable usage "usage: relmon list \[-H\] \[-f html|parseable|text\]\
  4.1361 +            \[-F url\]\n\
  4.1362 +            \                  \[-n number_items\] statefile\n\
  4.1363 +            \      relmon list -f atom -F url \[-n number_items\] statefile"
  4.1364 +
  4.1365 +    # configuration options
  4.1366 +    variable Config [dict create \
  4.1367 +            "format" "text" \
  4.1368 +            "show_history" 0 \
  4.1369 +            "history_limit" 100 \
  4.1370 +            "feed_url" ""]
  4.1371 +}
  4.1372 +
  4.1373 +proc ::relmon::list::FormatText {stateName includeHistory historyLimit} {
  4.1374 +    upvar 1 $stateName state
  4.1375 +    set output ""
  4.1376 +    append output [format "%-35s %-15s %-24s %-3s\n" "Project" "Version" \
  4.1377 +            "Refreshed" "St."]
  4.1378 +    append output [string repeat "-" 80]
  4.1379 +    append output "\n"
  4.1380 +
  4.1381 +    set history {}
  4.1382 +    dict for {name item} $state {
  4.1383 +        foreach historyItem [dict get $item "history"] {
  4.1384 +            lappend history [list [lindex $historyItem 1] $name \
  4.1385 +                    [lindex $historyItem 0]]
  4.1386 +        }
  4.1387 +        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
  4.1388 +        set timestamp [clock format [expr {[dict get $item "timestamp"] /
  4.1389 +                1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
  4.1390 +        set status [expr {[llength [dict get $item "errors"]] > 0 ? "E" : ""}]
  4.1391 +        append output [format "%-35s %15s %-24s %-1s\n" $name $latestVersion \
  4.1392 +                $timestamp $status]
  4.1393 +    }
  4.1394 +    if {$includeHistory} {
  4.1395 +        append output "\nHistory\n"
  4.1396 +        append output [string repeat "-" 80]
  4.1397 +        append output "\n"
  4.1398 +        set history [lsort -decreasing -integer -index 0 $history]
  4.1399 +        foreach historyItem [lrange $history 0 $historyLimit] {
  4.1400 +            append output [format "%-24s %-35s %15s\n" \
  4.1401 +                    [clock format [expr {[lindex $historyItem 0] / 1000}] \
  4.1402 +                    -format {%Y-%m-%dT%H:%M:%S%z}] [lindex $historyItem 1] \
  4.1403 +                    [lindex $historyItem 2]]
  4.1404 +        }
  4.1405 +    }
  4.1406 +
  4.1407 +    return $output
  4.1408 +}
  4.1409 +
  4.1410 +proc ::relmon::list::FormatParseable {stateName includeHistory historyLimit} {
  4.1411 +    upvar 1 $stateName state
  4.1412 +    set output ""
  4.1413 +    set history {}
  4.1414 +    dict for {name item} $state {
  4.1415 +        foreach historyItem [dict get $item "history"] {
  4.1416 +            lappend history [list [lindex $historyItem 1] $name \
  4.1417 +                    [lindex $historyItem 0]]
  4.1418 +        }
  4.1419 +        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
  4.1420 +        if {$latestVersion eq ""} {
  4.1421 +            set latestVersion -
  4.1422 +        }
  4.1423 +        set timestamp [clock format [expr {[dict get $item "timestamp"] /
  4.1424 +                1000}] -timezone :UTC -format {%Y-%m-%dT%H:%M:%SZ}]
  4.1425 +        set status [expr {[llength [dict get $item "errors"]] > 0 ? "ERROR" :
  4.1426 +                "OK"}]
  4.1427 +        append output [format "%s\t%s\t%s\t%s\n" $name $latestVersion \
  4.1428 +                $timestamp $status]
  4.1429 +    }
  4.1430 +    if {$includeHistory} {
  4.1431 +        append output "\n"
  4.1432 +        set history [lsort -decreasing -integer -index 0 $history]
  4.1433 +        foreach historyItem [lrange $history 0 $historyLimit] {
  4.1434 +            append output [format "%s\t%s\t%s\n" [clock format \
  4.1435 +                    [expr {[lindex $historyItem 0] / 1000}] -timezone :UTC \
  4.1436 +                    -format {%Y-%m-%dT%H:%M:%SZ}] [lindex $historyItem 1] \
  4.1437 +                    [lindex $historyItem 2]]
  4.1438 +        }
  4.1439 +    }
  4.1440 +    return $output
  4.1441 +}
  4.1442 +
  4.1443 +proc ::relmon::list::FormatHtml {stateName includeHistory historyLimit
  4.1444 +        feedUrl} {
  4.1445 +    upvar 1 $stateName state
  4.1446 +
  4.1447 +    set output "<html>\n"
  4.1448 +    append output "<head>\n"
  4.1449 +    append output "<title>Current Releases</title>\n"
  4.1450 +    if {$feedUrl ne ""} {
  4.1451 +        append output "<link type=\"application/atom+xml\" rel=\"alternate\"\
  4.1452 +                title=\"Release History\"\
  4.1453 +                href=\"[html::html_entities $feedUrl]\"/>\n"
  4.1454 +    }
  4.1455 +    append output "</head>\n"
  4.1456 +    append output "<body>\n"
  4.1457 +    append output "<h1>Current Releases</h1>\n<table>\n<tr>\n<th>Project</th>\
  4.1458 +            \n<th>Version</th>\n<th>Refreshed</th>\n<th>Status</th>\n</tr>\n"
  4.1459 +    set history {}
  4.1460 +    dict for {name item} $state {
  4.1461 +        foreach historyItem [dict get $item "history"] {
  4.1462 +            lappend history [list [lindex $historyItem 1] $name \
  4.1463 +                    [lindex $historyItem 0]]
  4.1464 +        }
  4.1465 +        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
  4.1466 +        set timestamp [clock format [expr {[dict get $item "timestamp"] /
  4.1467 +                1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
  4.1468 +        set status [expr {[llength [dict get $item "errors"]] > 0 ? "Error" :
  4.1469 +                "OK"}]
  4.1470 +
  4.1471 +        append output "<tr>\n<td>[html::html_entities $name]</td>\n"
  4.1472 +        if {$latestVersion ne ""} {
  4.1473 +            if {[dict exists $item "versions" $latestVersion]} {
  4.1474 +                set url [dict get $item "versions" $latestVersion]
  4.1475 +                append output "<td><a\
  4.1476 +                        href=\"[html::html_entities $url]\"\
  4.1477 +                        title=\"[html::html_entities\
  4.1478 +                        "$name $latestVersion"]\">[html::html_entities \
  4.1479 +                        $latestVersion]</a></td>\n"
  4.1480 +            } else {
  4.1481 +                append output "<td>[html::html_entities \
  4.1482 +                        $latestVersion]</td>\n"
  4.1483 +            }
  4.1484 +        } else {
  4.1485 +            append output "<td></td>\n"
  4.1486 +        }
  4.1487 +        append output "<td>$timestamp</td>\n"
  4.1488 +        append output "<td>[html::html_entities $status]</td>\n</tr>\n"
  4.1489 +    }
  4.1490 +    append output "</table>\n"
  4.1491 +
  4.1492 +    if {$includeHistory} {
  4.1493 +        set history [lsort -decreasing -integer -index 0 $history]
  4.1494 +        append output "<h1>Release History</h1>\n<table>\n"
  4.1495 +        append output "<tr><th>Time</th><th>Project</th><th>Version</th></tr>\n"
  4.1496 +        foreach historyItem [lrange $history 0 $historyLimit] {
  4.1497 +            set timestamp [clock format [expr {[lindex $historyItem 0] /
  4.1498 +                    1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
  4.1499 +            set name [lindex $historyItem 1]
  4.1500 +            set version [lindex $historyItem 2]
  4.1501 +            append output "<tr>\n<td>$timestamp</td>\n"
  4.1502 +            append output "<td>[html::html_entities $name]</td>\n"
  4.1503 +            append output "<td>[html::html_entities $version]</td></tr>\n"
  4.1504 +        }
  4.1505 +        append output "</table>\n"
  4.1506 +    }
  4.1507 +
  4.1508 +    append output "</body>\n</html>\n"
  4.1509 +
  4.1510 +    return $output
  4.1511 +}
  4.1512 +
  4.1513 +proc ::relmon::list::FormatAtom {stateName historyLimit feedUrl} {
  4.1514 +    upvar 1 $stateName state
  4.1515 +    set host [::relmon::common::urlGetHost $feedUrl]
  4.1516 +    set output "<?xml version=\"1.0\" encoding=\"utf-8\"?>\
  4.1517 +            \n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n"
  4.1518 +    append output "<author><name>relmon</name></author>\n"
  4.1519 +    append output "<title>Release History</title>\n"
  4.1520 +    append output "<id>[html::html_entities $feedUrl]</id>\n"
  4.1521 +    set history {}
  4.1522 +    dict for {name item} $state {
  4.1523 +        foreach historyItem [dict get $item "history"] {
  4.1524 +            lappend history [list [lindex $historyItem 1] $name \
  4.1525 +                    [lindex $historyItem 0]]
  4.1526 +        }
  4.1527 +    }
  4.1528 +    set history [lsort -decreasing -integer -index 0 $history]
  4.1529 +    set updated [lindex [lindex $history end] 0]
  4.1530 +    if {$updated eq ""} {
  4.1531 +        set updated [clock seconds]
  4.1532 +    }
  4.1533 +    append output "<updated>[clock format $updated \
  4.1534 +            -format {%Y-%m-%dT%H:%M:%S%z}]</updated>\n"
  4.1535 +    foreach historyItem [lrange $history 0 $historyLimit] {
  4.1536 +        set name [lindex $historyItem 1]
  4.1537 +        set version [lindex $historyItem 2]
  4.1538 +        set timestamp [clock format [expr {[lindex $historyItem 0] / 1000}] \
  4.1539 +                -format {%Y-%m-%dT%H:%M:%S%z}]
  4.1540 +        set id "tag:$host,[clock format [lindex $historyItem 0] \
  4.1541 +                -format {%Y-%m-%d}]:[uri::urn::quote $name-$version]"
  4.1542 +        append output "<entry>\n"
  4.1543 +        append output "<id>[html::html_entities $id]</id>\n"
  4.1544 +        append output "<updated>$timestamp</updated>\n"
  4.1545 +        append output "<title>[html::html_entities "$name $version"]</title>"
  4.1546 +        append output "<content>[html::html_entities \
  4.1547 +                "$name $version"]</content>\n"
  4.1548 +        append output "</entry>\n"
  4.1549 +    }
  4.1550 +    append output "</feed>\n"
  4.1551 +    return $output
  4.1552 +}
  4.1553 +
  4.1554 +proc ::relmon::list::main {args} {
  4.1555 +    variable usage
  4.1556 +    variable Config
  4.1557 +
  4.1558 +    # parse commandline
  4.1559 +    while {[set GetoptRet [cmdline::getopt args {f.arg F.arg H n.arg} OptArg \
  4.1560 +            OptVal]] == 1} {
  4.1561 +        switch -glob -- $OptArg {
  4.1562 +            {f} {
  4.1563 +                if {$OptVal ni {atom html parseable text}} {
  4.1564 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1565 +                    exit 1
  4.1566 +                }
  4.1567 +                dict set Config "format" $OptVal
  4.1568 +            }
  4.1569 +            {F} {
  4.1570 +                if {[catch {dict create {*}[uri::split $OptVal]} UrlParts] ||
  4.1571 +                        ([dict get $UrlParts "host"] eq "")} {
  4.1572 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1573 +                    exit 1
  4.1574 +                }
  4.1575 +                dict set Config "feed_url" $OptVal
  4.1576 +            }
  4.1577 +            {H} {
  4.1578 +                dict set Config "show_history" 1
  4.1579 +            }
  4.1580 +            {n} {
  4.1581 +                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
  4.1582 +                    puts stderr "invalid value passed to \"-$OptArg\""
  4.1583 +                    exit 1
  4.1584 +                }
  4.1585 +                dict set Config "history_limit" [expr {$OptVal - 1}]
  4.1586 +            }
  4.1587 +        }
  4.1588 +    }
  4.1589 +    set argc [llength $args]
  4.1590 +    if {$GetoptRet == -1} {
  4.1591 +        puts stderr "unknown command line option \"-$OptArg\""
  4.1592 +        puts stderr $usage
  4.1593 +        exit 1
  4.1594 +    }
  4.1595 +    if {$argc != 1} {
  4.1596 +        puts stderr $usage
  4.1597 +        exit 1
  4.1598 +    }
  4.1599 +    if {([dict get $Config "format"] eq "atom") &&
  4.1600 +            ([dict get $Config "feed_url"] eq "")} {
  4.1601 +        puts stderr "mandatory \"-F\" option is missing"
  4.1602 +        puts stderr $usage
  4.1603 +        exit 1
  4.1604 +    }
  4.1605 +    set StateFile [lindex $args 0]
  4.1606 +
  4.1607 +    # read the state file
  4.1608 +    try {
  4.1609 +        set State [::relmon::common::parseStateFile $StateFile]
  4.1610 +    } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
  4.1611 +        puts stderr $errorMsg
  4.1612 +        exit 1
  4.1613 +    }
  4.1614 +
  4.1615 +    # call formatter
  4.1616 +    switch -- [dict get $Config "format"] {
  4.1617 +        {atom} {
  4.1618 +            puts -nonewline [FormatAtom State \
  4.1619 +                    [dict get $Config "history_limit"] \
  4.1620 +                    [dict get $Config "feed_url"]]
  4.1621 +        }
  4.1622 +        {html} {
  4.1623 +            puts -nonewline [FormatHtml State \
  4.1624 +                    [dict get $Config "show_history"] \
  4.1625 +                    [dict get $Config "history_limit"] \
  4.1626 +                    [dict get $Config "feed_url"]]
  4.1627 +        }
  4.1628 +        {parseable} {
  4.1629 +            puts -nonewline [FormatParseable State \
  4.1630 +                    [dict get $Config "show_history"] \
  4.1631 +                    [dict get $Config "history_limit"]]
  4.1632 +        }
  4.1633 +        {default} {
  4.1634 +            puts -nonewline [FormatText State \
  4.1635 +                    [dict get $Config "show_history"] \
  4.1636 +                    [dict get $Config "history_limit"]]
  4.1637 +        }
  4.1638 +    }
  4.1639 +
  4.1640 +    exit 0
  4.1641 +}
  4.1642 +
  4.1643 +
  4.1644 +namespace eval ::relmon::help {
  4.1645 +    # commandline option help text
  4.1646 +    variable usage "usage: relmon help \[subcommand\]"
  4.1647 +}
  4.1648 +
  4.1649 +proc ::relmon::help::main {args} {
  4.1650 +    variable usage
  4.1651 +
  4.1652 +    # parse commandline
  4.1653 +    if {[cmdline::getopt args {} OptArg OptVal] == -1} {
  4.1654 +        puts stderr "unknown command line option \"-$OptArg\""
  4.1655 +        puts stderr $usage
  4.1656 +        exit 1
  4.1657 +    }
  4.1658 +    set argc [llength $args]
  4.1659 +    if {$argc > 1} {
  4.1660 +        puts stderr $usage
  4.1661 +        exit 1
  4.1662 +    }
  4.1663 +    set subCommand [lindex $args 0]
  4.1664 +    if {$subCommand ne ""} {
  4.1665 +        if {[info procs ::relmon::${subCommand}::main] ne ""} {
  4.1666 +            puts stderr [set ::relmon::${subCommand}::usage]
  4.1667 +        } else {
  4.1668 +            puts stderr "unknown subcommand \"$subCommand\""
  4.1669 +            puts stderr $usage
  4.1670 +            exit 1
  4.1671 +        }
  4.1672 +    } else {
  4.1673 +        foreach subCommandNs [namespace children ::relmon] {
  4.1674 +            if {[info procs ${subCommandNs}::main] ne ""} {
  4.1675 +                puts stderr [set ${subCommandNs}::usage]
  4.1676 +            }
  4.1677 +        }
  4.1678 +    }
  4.1679 +    exit 0
  4.1680 +}
  4.1681 +
  4.1682 +
  4.1683 +proc ::relmon::main {args} {
  4.1684 +    variable usage
  4.1685 +    set subArgs [lassign $args subCommand]
  4.1686 +
  4.1687 +    # generate list of subcommands
  4.1688 +    set subCommands {}
  4.1689 +    foreach subCommandNs [namespace children ::relmon] {
  4.1690 +        if {[info procs ${subCommandNs}::main] ne ""} {
  4.1691 +            lappend subCommands [namespace tail $subCommandNs]
  4.1692 +        }
  4.1693 +    }
  4.1694 +    if {$subCommand ni $subCommands} {
  4.1695 +        if {$subCommand ne ""} {
  4.1696 +            puts stderr "unknown subcommand \"$subCommand\""
  4.1697 +        }
  4.1698 +        foreach command $subCommands {
  4.1699 +            puts stderr [set relmon::${command}::usage]
  4.1700 +        }
  4.1701 +        exit 1
  4.1702 +    }
  4.1703 +
  4.1704 +    # dispatch subcommand
  4.1705 +    relmon::${subCommand}::main {*}$subArgs
  4.1706 +}
  4.1707 +
  4.1708 +
  4.1709 +relmon::main {*}$argv