Mercurial > projects > relmon

comparison relmon.tcl.in @ 3:6d87242c537e

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