Mercurial > projects > relmon

comparison relmon.tcl @ 0:8c5330f6e9e4

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