#!/usr/bin/tclsh
#
# Copyright (C) 2014 Guido Berhoerster <guido+relmon@berhoerster.name>
#
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be included
# in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

package require Tcl 8.5
package require http
package require tls
package require tdom
package require try
package require cmdline
package require control
package require html
package require htmlparse
package require json
package require json::write
package require logger
package require logger::utils
package require textutil::split
package require uri
package require uri::urn


namespace eval ::relmon {
    # version
    variable VERSION @VERSION@

    # default log format
    variable LogFormatDefault {%d \[%p\] %m}

    # debugging log format
    variable LogFormatDebug {%d \[%p\] \[%M\] %m}
}


namespace eval ::relmon::common {
    namespace export cmpVersions isUrlValid urlGetHost normalizeHttpHeaders \
            parseStateFile
}

# implementation of the Debian version comparison algorithm described at
# http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version
proc ::relmon::common::cmpVersion {v1 v2} {
    set v1Len [string length $v1]
    set v2Len [string length $v2]
    set v1Pos 0
    set v2Pos 0
    while {($v1Pos < $v1Len) || ($v2Pos < $v2Len)} {
        set firstNumDiff 0
        # until reaching ASCII digits in both version strings compare character
        # values which are modified as so they are sorted in the following
        # order:
        # - "~"
        # - missing character or ASCII digits
        # - ASCII alphabet
        # - everything else in the order of their unicode value
        while {(($v1Pos < $v1Len) &&
                ![string match {[0123456789]} [string index $v1 $v1Pos]]) ||
                (($v2Pos < $v2Len) &&
                ![string match {[0123456789]} [string index $v2 $v2Pos]])} {
            foreach char [list [string index $v1 $v1Pos] \
                    [string index $v2 $v2Pos]] charValueName \
                    {v1CharValue v2CharValue} {
                if {$char eq "~"} {
                    set $charValueName -1
                } elseif {$char eq ""} {
                    set $charValueName 0
                } elseif {[string match {[0123456789]} $char]} {
                    set $charValueName 0
                } elseif {[string match -nocase {[abcdefghijklmnopqrstuvwxyz]} \
                        $char]} {
                    set $charValueName [scan $char "%c"]
                } else {
                    set $charValueName [expr {[scan $char "%c"] + 0x7f + 1}]
                }
            }
            if {$v1CharValue != $v2CharValue} {
                return [expr {$v1CharValue - $v2CharValue}]
            }
            incr v1Pos
            incr v2Pos
        }

        # strip leading zeros
        while {[string index $v1 $v1Pos] eq "0"} {
            incr v1Pos
        }
        while {[string index $v2 $v2Pos] eq "0"} {
            incr v2Pos
        }

        # process digits until reaching a non-digit
        while {[string match {[0123456789]} [string index $v1 $v1Pos]] &&
                [string match {[0123456789]} [string index $v2 $v2Pos]]} {
            # record the first difference between the two numbers
            if {$firstNumDiff == 0} {
                set firstNumDiff [expr {[string index $v1 $v1Pos] -
                        [string index $v2 $v2Pos]}]
            }
            incr v1Pos
            incr v2Pos
        }

        # return if the number of one version has more digits than the other
        # since the one with more digits is the larger number
        if {[string match {[0123456789]} [string index $v1 $v1Pos]]} {
            return 1
        } elseif {[string match {[0123456789]} [string index $v2 $v2Pos]]} {
            return -1
        }

        # return the difference if the digits differed above
        if {$firstNumDiff != 0} {
            return $firstNumDiff
        }
    }

    return 0
}

proc ::relmon::common::isUrlValid {url} {
    return [expr {![catch {dict create {*}[uri::split $url]} urlParts] &&
            ([dict get $urlParts "scheme"] in {"http" "https"}) &&
            ([dict get $urlParts "host"] ne "")}]
}

proc ::relmon::common::urlGetHost {url} {
    return [expr {(![catch {dict create {*}[uri::split $url]} urlParts]) ?
                [dict get $urlParts "host"] : ""}]
}

proc ::relmon::common::normalizeHttpHeaders {headers} {
    set httpHeaders [dict create]
    foreach {header value} $headers {
        set words {}
        foreach word [split $header "-"] {
            lappend words [string totitle $word]
        }
        dict set httpHeaders [join $words "-"] $value
    }
    return $httpHeaders
}

proc ::relmon::common::parseStateFile {stateFile} {
    try {
        set f [open $stateFile "r"]
    } trap {POSIX} {errorMsg errorOptions} {
        return -options $errorOptions \
                "failed to open state file \"$stateFile\": $errorMsg"
    }
    try {
        set state [json::json2dict [chan read $f]]
    } trap {POSIX} {errorMsg errorOptions} {
        return -options $errorOptions \
                "failed to read from state file \"$stateFile\": $errorMsg"
    } on error {errorMsg errorOptions} {
        # the json package does not set an error code
        dict set errorOptions "-errorcode" {RELMON JSON_PARSE_ERROR}
        return -options $errorOptions \
                "failed to parse state file \"$stateFile\": $errorMsg"
    } finally {
        close $f
    }

    return $state
}

proc ::relmon::common::parseWatchlist {watchlistFilename} {
    set Watchlist [dict create]
    set lineno 0
    set f [open $watchlistFilename "r"]
    try {
        while {[chan gets $f line] != -1} {
            set fields [textutil::split::splitx [string trim $line] {[\t ]+}]
            incr lineno

            if {([llength $fields] == 0) ||
                    ([string index [lindex $fields 0] 0] eq "#")} {
                # skip empty lines and comments
                continue
            } elseif {[llength $fields] < 3} {
                # a line consists of a name, base URL and at least one
                # version-matching pattern
                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
                        "syntax error in \"$watchlistFilename\" line $lineno"
            }

            set patterns [lassign $fields name baseUrl]

            # validate URL
            if {![::relmon::common::isUrlValid $baseUrl]} {
                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
                        "syntax error in \"$watchlistFilename\" line $lineno:\
                        invalid base URL"
            }

            # process patterns
            set processedPatterns {}
            set patternIndex 0
            foreach pattern $patterns {
                incr patternIndex

                # make trailing slashes optional except in the last
                # version-matching pattern
                if {($patternIndex != [llength $patterns]) &&
                        ([string index $pattern end] eq "/")} {
                    append pattern {?}
                }

                # ensure patterns are anchored to the end of the line
                if {[string index $pattern end] ne "$"} {
                    append pattern {$}
                }

                # actually validate the regular expression
                try {
                    set reInfo [regexp -about -- $pattern ""]
                } on error {errorMsg} {
                    return -code error \
                            -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
                            "error in \"$watchlistFilename\" line $lineno:\
                            $errorMsg"
                }
                lappend processedPatterns $pattern
            }
            if {[lindex $reInfo 0] < 1} {
                return -code error -errorcode {RELMON WATCHLIST_PARSE_ERRROR} \
                        "syntax error in \"$watchlistFilename\" line $lineno:\
                        the last regular expression must contain at least one
                        capturing group"
            }

            dict set Watchlist $name "base_url" $baseUrl
            dict set Watchlist $name "patterns" $processedPatterns
        }
    } finally {
        close $f
    }

    return $Watchlist
}


namespace eval ::relmon::crawler {
    # status returned by crawl
    variable Status

    # configuration
    variable Config

    # transfer statistics
    variable Statistics [dict create \
            "start_time" 0 \
            "end_time" 0 \
            "requests" 0 \
            "items" 0]

    # ID of a delayed run of ManageTransfers
    variable ManageTransfersId ""

    # queue of pending transfers
    variable Queue

    # number of active connections per host
    variable HostConnections [dict create]

    # delays before opening a new connection to a host
    variable HostDelays [dict create]

    # active transfers
    variable ActiveTransfers [dict create]

    # number of running or queued transfers of watchlist items
    variable RemainingTransfers [dict create]

    # buffer for tracking the state of unfinished items
    variable StateBuffer [dict create]

    # buffer needed by htmlparse::parse for constructing the preprocessed HTML
    # document
    variable PreprocessedHtmlBuffer

    # callback when all transfers for an item are finished
    variable OnItemFinishedCmd

    # logger handle
    variable Log

    namespace export crawl
}

proc ::relmon::crawler::OnError {message returnOptions} {
    # internal error, abort
    puts stderr [dict get $returnOptions "-errorinfo"]

    exit 1
}

proc ::relmon::crawler::ProcessHtmlElement {tag slash param textBehindTheTag} {
    variable PreprocessedHtmlBuffer

    # copy every "<a>" element into PreprocessedHtmlBuffer
    if {($slash eq "") && ([string tolower $tag] eq "a")} {
        append PreprocessedHtmlBuffer "<$tag $param></$tag>"
    }

    return
}

proc ::relmon::crawler::PreprocessHtml {bodyDataName} {
    upvar 1 $bodyDataName bodyData
    variable PreprocessedHtmlBuffer

    # preprocess the document with htmlparse by constructing a new document
    # consisting only of found "<a>" elements which then can be fed into tdom
    # again; this is useful if parsing via tdom fails; however, htmlparse
    # should only be used as a last resort because it is just too limited, it
    # gets easily confused within "<script>" elements and lacks attribute
    # parsing
    set PreprocessedHtmlBuffer "<html><body>"
    htmlparse::parse -cmd [namespace code ProcessHtmlElement] $bodyData
    append PreprocessedHtmlBuffer "</body></html>"
}

proc ::relmon::crawler::ExtractUrls {bodyDataName contentType baseUrl
        rePattern} {
    upvar 1 $bodyDataName bodyData
    set extractedUrls {}
    set resultUrls [dict create]
    # extract all URLs or URL fragments
    switch -- $contentType {
        {text/html} -
        {application/xhtml+xml} {
            # HTML/XHTML
            # if tdom parsing has failed or not found any "<a>" element,
            # preprocess the document with htmlparse and try again
            if {[catch {dom parse -html $bodyData} doc] ||
                    ([set rootElement [$doc documentElement]] eq "") ||
                    ([llength [set aElements \
                    [$rootElement selectNodes {descendant::a}]]] == 0)} {
                try {
                    set doc [dom parse -html [PreprocessHtml bodyData]]
                } on error {errorMsg errorOptions} {
                    dict set errorOptions "-errorcode" \
                            {RELMON TDOM_PARSE_ERROR}
                    return -options $errorOptions $errorMsg
                }
                set rootElement [$doc documentElement]
                set aElements [$rootElement selectNodes {descendant::a}]
            }
            foreach node $aElements {
                set href [$node getAttribute "href" ""]
                if {$href ne ""} {
                    lappend extractedUrls $href
                }
            }
            $doc delete
        }
        {application/rss+xml} {
            # RSS 2.0
            try {
                set doc [dom parse $bodyData]
            } on error {errorMsg errorOptions} {
                dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
                return -options $errorOptions $errorMsg
            }
            set rootElement [$doc documentElement]
            if {$rootElement ne ""} {
                foreach node [$rootElement selectNodes {descendant::link}] {
                    set linkText [$node text]
                    if {$linkText ne ""} {
                        lappend extractedUrls $linkText
                    }
                }
            }
            $doc delete
        }
        {application/atom+xml} {
            # Atom 1.0
            try {
                set doc [dom parse $bodyData]
            } on error {errorMsg errorOptions} {
                dict set errorOptions "-errorcode" {RELMON TDOM_PARSE_ERROR}
                return -options $errorOptions $errorMsg
            }
            set rootElement [$doc documentElement]
            if {$rootElement ne ""} {
                foreach node [$rootElement selectNodes {descendant::link}] {
                    set href [$node getAttribute "href" ""]
                    if {$href ne ""} {
                        lappend extractedUrls $href
                    }
                }
            }
            $doc delete
        }
        {text/plain} {
            # plain text
            foreach line [split $bodyData "\n"] {
                if {$line ne ""} {
                    lappend extractedUrls $line
                }
            }
        }
        default {
            return -code error \
                    -errorcode {RELMON UNSUPPORTED_CONTENT_TYPE_ERROR} \
                    "unsupported content type \"$contentType\""
        }
    }
    foreach url $extractedUrls {
        set normalizedUrl [uri::canonicalize [uri::resolve $baseUrl $url]]
        dict set resultUrls $normalizedUrl \
                [expr {[regexp -line -- $rePattern $normalizedUrl] ? 1 : 0}]
    }

    return $resultUrls
}

proc ::relmon::crawler::StateItemAppendError {name logMsg} {
    variable StateBuffer

    dict update StateBuffer $name stateItem {
        dict lappend stateItem "errors" $logMsg
    }

    return
}

proc ::relmon::crawler::HandleSuccessfulTransfer {item httpBodyName} {
    upvar 1 $httpBodyName httpBody
    variable Log
    variable StateBuffer
    variable Queue
    variable RemainingTransfers
    variable Watchlist

    set name [dict get $item "name"]
    set url [dict get $item "url"]
    set patternIndex [dict get $item "pattern_index"]
    set pattern [lindex [dict get $Watchlist $name "patterns"] $patternIndex]

    ${Log}::info "\"$name\": \"$url\": transfer finished"

    # parse data
    try {
        set urls [ExtractUrls httpBody [dict get $item "content_type"] $url \
                $pattern]
    } trap {RELMON} {errorMsg} {
        # continue on tdom parsing errors or when receiving documents with an
        # unsupported content type
        set urls [dict create]
        set warningMsg "\"$name\": \"$url\": failed to parse data: $errorMsg"
        ${Log}::warn $warningMsg
        StateItemAppendError $name $warningMsg
    }

    if {$patternIndex < ([llength \
            [dict get $Watchlist $name "patterns"]] - 1)} {
        # if this is not the last, version-matching pattern, queue matched URLs
        dict for {newUrl matched} $urls {
            if {$matched} {
                if {![::relmon::common::isUrlValid $newUrl]} {
                    ${Log}::debug "\"$name\": \"$url\": ignoring matched but\
                            invalid URL \"$newUrl\""
                    continue
                }

                ${Log}::debug "\"$name\": \"$url\": queuing \"$newUrl\""

                dict lappend Queue [::relmon::common::urlGetHost $newUrl] \
                        [dict create "name" $name "url" $newUrl \
                        "pattern_index" [expr {$patternIndex + 1}] \
                        "content_type" "" "num_redirects" 0 "num_retries" 0]
                dict incr RemainingTransfers $name
            } else {
                ${Log}::debug "\"$name\": \"$url\": ignoring \"$newUrl\""
            }
        }
    } else {
        # otherwise this branch has finished, try to extract the versions and
        # store them in the buffer
        dict for {finalUrl matched} $urls {
            dict set StateBuffer $name "urls" $url $urls
            if {$matched} {
                regexp -line -- $pattern $finalUrl -> version
                if {$version ne ""} {
                    ${Log}::debug "\"$name\": \"$url\": extracted version\
                            \"$version\" from \"$finalUrl\" found on\
                            \"$url\""
                    dict set StateBuffer $name "versions" $version $finalUrl
                } else {
                    ${og}::debug "\"$name\": \"$url\": could not extract a\
                            version from \"$finalUrl\""
                }
            } else {
                ${Log}::debug "\"$name\": \"$url\": ignoring \"$finalUrl\""
            }
        }
    }

    return
}

proc ::relmon::crawler::HandleRedirect {item httpCode httpHeaders} {
    variable Log
    variable Queue
    variable RemainingTransfers

    set name [dict get $item "name"]
    set url [dict get $item "url"]

    if {![dict exists $httpHeaders "Location"]} {
        # bail out in case of an invalid HTTP response
        set warningMsg "\"$name\": \"$url\": transfer failed: invalid HTTP\
                response"
        ${Log}::warn $warningMsg
        StateItemAppendError $name $warningMsg
        return
    }
    set location [dict get $httpHeaders "Location"]

    # sanitize URL from Location header
    if {[uri::isrelative $location]} {
        set redirectUrl [uri::canonicalize [uri::resolve \
                $url $location]]
    } else {
        if {![::relmon::common::isUrlValid $location]} {
            # bail out in case of an invalid redirect URL
            set warningMsg "\"$name\": \"$url\": received invalid redirect URL\
                    \"$location\""
            ${Log}::warn $warningMsg
            StateItemAppendError $name $warningMsg
            return
        }
        set redirectUrl [uri::canonicalize $location]
    }

    ${Log}::notice "\"$name\": \"$url\": received redirect to \"$redirectUrl\""

    # handle up to 10 redirects by re-queuing the target URL
    if {[dict get $item "num_redirects"] < 10} {
        ${Log}::debug "\"$name\": \"$url\": queuing \"$redirectUrl\" due to\
                redirect"

        dict lappend Queue [::relmon::common::urlGetHost $redirectUrl] \
                [dict replace $item "url" $redirectUrl "content_type" "" \
                "num_redirects" [expr {[dict get $item "num_redirects"] + 1}] \
                "num_retries" 0]
        dict incr RemainingTransfers $name
    } else {
        set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
                redirects"
        ${Log}::warn $warningMsg
        StateItemAppendError $name $warningMsg
    }

    return
}

proc ::relmon::crawler::HandleProtocolError {item httpCode} {
    variable Log
    set name [dict get $item "name"]
    set url [dict get $item "url"]
    set warningMsg "\"$name\": \"$url\": transfer failed: $httpCode"
    ${Log}::warn $warningMsg
    StateItemAppendError $name $warningMsg
    return
}

proc ::relmon::crawler::HandleTimeoutReset {item} {
    variable Log
    variable Config
    variable Queue
    variable RemainingTransfers
    set name [dict get $item "name"]
    set url [dict get $item "url"]

    # retry by re-queuing the target URL until reaching the limit
    if {[dict get $item "num_retries"] < [dict get $Config "retry_limit"]} {
        ${Log}::warn "\"$name\": \"$url\": connection timed out or was reset,\
                retrying"
        dict lappend Queue [::relmon::common::urlGetHost $url] \
                [dict replace $item \
                "num_retries" [expr {[dict get $item "num_retries"] + 1}]]
        dict incr RemainingTransfers $name
    } else {
        set warningMsg "\"$name\": \"$url\": exceeded maximum number of\
                retries"
        ${Log}::warn $warningMsg
        StateItemAppendError $name $warningMsg
    }

    return
}

proc ::relmon::crawler::HandleConnectionError {item errorMsg} {
    variable Log
    set name [dict get $item "name"]
    set url [dict get $item "url"]
    set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
    ${Log}::warn $warningMsg
    StateItemAppendError $name $warningMsg
    return
}

proc ::relmon::crawler::TransferCallbackWrapper {callbackCmd args} {
    # ensure that exceptions get raised, by default http catches all errors and
    # silently ignores them, see https://core.tcl.tk/tcl/tktview?name=1414262
    if {[catch {eval $callbackCmd $args} -> errorOptions]} {
        OnError [dict get $errorOptions "-errorinfo"] $errorOptions
    }
    return
}

proc ::relmon::crawler::ManageTransfers {} {
    variable Config
    variable ManageTransfersId
    variable Queue
    variable HostConnections
    variable HostDelays
    variable ActiveTransfers
    variable RemainingTransfers
    variable Status
    variable Log

    after cancel $ManageTransfersId

    # try to initiate new transfers
    while {([dict size $ActiveTransfers] <
            [dict get $Config "connection_limit"]) &&
            ([dict size $Queue] > 0)} {
        # find URLs in the queue with a host for which we have not reached the
        # per-host connection limit yet and for which no delay is in effect
        set item {}
        dict for {host items} $Queue {
            set now [clock milliseconds]

            if {![dict exists $HostConnections $host]} {
                dict set HostConnections $host 0
            }

            if {![dict exists $HostDelays $host]} {
                dict set HostDelays $host $now
            }

            if {([dict get $HostConnections $host] <
                    [dict get $Config "host_connection_limit"]) &&
                    ([dict get $HostDelays $host] <= $now)} {
                # pop item from the queue
                set items [lassign $items item]
                if {[llength $items] > 0} {
                    dict set Queue $host $items
                } else {
                    dict unset Queue $host
                }

                dict incr HostConnections $host
                # set a random delay before the next connection to this host
                # can be made
                dict set HostDelays $host \
                        [expr {[clock milliseconds] + int((rand() + 0.5) *
                        [dict get $Config "host_delay"])}]
                break
            }
        }
        # if no item could be found, the per-host connection limit for all
        # queued URLs has been reached and no new transfers may be started
        # at this point
        if {$item eq {}} {
            break
        }
        # otherwise start a new transfer
        set url [dict get $item "url"]
        set name [dict get $item "name"]
        try {
            set token [http::geturl $url \
                    -timeout [dict get $Config "transfer_time_limit"] \
                    -progress [namespace code {TransferCallbackWrapper \
                    OnTransferProgress}] \
                    -command [namespace code {TransferCallbackWrapper \
                    OnTransferFinished}]]
        } on ok {} {
            dict set ActiveTransfers $token $item

            ${Log}::info "\"$name\": \"$url\": starting transfer"
        } on error {errorMsg} {
            # an error occured during socket setup, e.g. a DNS lookup failure
            set warningMsg "\"$name\": \"$url\": transfer failed: $errorMsg"
            ${Log}::warn $warningMsg
            StateItemAppendError $name $warningMsg
            dict incr RemainingTransfers $name -1
        }
    }

    # terminate the event loop if there are no remaining transfers
    if {[::tcl::mathop::+ {*}[dict values $RemainingTransfers]] == 0} {
        if {([dict size $ActiveTransfers]) > 0 || ([dict size $Queue] > 0)} {
            ${Log}::error "inconsistent internal state"
            set Status 1
        }
        set Status 0
        return
    }

    # due to per-host connection limits and per-host delays the maximum number
    # of connections may not be reached although there are still items in the
    # queue, in this case schedule ManageTransfers again after the smallest of
    # the current per-host delays
    set delay 0
    if {([dict size $ActiveTransfers] <
            [dict get $Config "connection_limit"]) &&
            ([dict size $Queue] > 0)} {
        dict for {host items} $Queue {
            if {(![dict exists $HostConnections $host] ||
                    ([dict get $HostConnections $host] <
                    [dict get $Config "host_connection_limit"])) &&
                    ([dict exists $HostDelays $host] &&
                    ([dict get $HostDelays $host] > $now))} {
                set hostDelay [expr {[dict get $HostDelays $host] - $now + 1}]
                if {(($delay == 0) ||
                        ($hostDelay < $delay))} {
                    set delay $hostDelay
                }
            }
        }
        if {$delay > 0} {
            set ManageTransfersId \
                    [after $delay [namespace code ManageTransfers]]
        }
    }

    return
}

proc ::relmon::crawler::OnTransferProgress {token total current} {
    upvar #0 $token httpState
    variable ActiveTransfers
    variable Log

    # try to determine content type and abort transfer if content type is not
    # one that can be parsed, this is primarily to prevent accidental downloads
    if {[dict get $ActiveTransfers $token "content_type"] eq ""} {
        set httpHeaders [relmon::common::normalizeHttpHeaders \
                $httpState(meta)]

        if {[dict exists $httpHeaders "Content-Type"]} {
            set contentType [string trim [lindex [split \
                    [dict get $httpHeaders "Content-Type"] ";"] 0]]
            dict set ActiveTransfers $token "content_type" $contentType
            if {$contentType ni {"text/html" "application/xhtml+xml"
                    "application/atom+xml" "application/rss+xml"
                    "text/plain"}} {
                ${Log}::warn "\"[dict get $ActiveTransfers $token "name"]\":\
                        \"[dict get $ActiveTransfers $token "url"]\": content\
                        type \"$contentType\" is not acceptable"
                http::reset $token
            }
        }
    }
}

proc ::relmon::crawler::OnTransferFinished {token} {
    upvar #0 $token httpState
    variable Config
    variable HostConnections
    variable ActiveTransfers
    variable RemainingTransfers
    variable Statistics
    variable StateBuffer
    variable State
    variable Log
    variable OnItemFinishedCmd

    set item [dict get $ActiveTransfers $token]
    set name [dict get $item "name"]
    set host [relmon::common::urlGetHost [dict get $item "url"]]

    # update list of per-host connections, and number of remaining transfers
    # for this item
    dict unset ActiveTransfers $token
    dict incr HostConnections $host -1
    dict incr RemainingTransfers $name -1

    switch -- $httpState(status) {
        {ok} {
            # normalize headers
            set httpHeaders [relmon::common::normalizeHttpHeaders \
                    $httpState(meta)]

            # try to determine content type
            if {([dict get $item "content_type"] eq "") &&
                    [dict exists $httpHeaders "Content-Type"]} {
                dict set item "content_type" [string trim [lindex [split \
                        [dict get $httpHeaders "Content-Type"] ";"] 0]]
            }

            # dispatch based on HTTP status code
            set httpCode [http::ncode $token]
            switch -glob -- $httpCode {
                {30[12378]} {
                    HandleRedirect $item $httpCode $httpHeaders
                }
                {200} {
                    HandleSuccessfulTransfer $item httpState(body)
                }
                default {
                    HandleProtocolError $item $httpState(http)
                }
            }
        }
        {reset} {
            # aborted due to wrong content type
        }
        {eof} -
        {timeout} {
            # timeout or connection reset
            HandleTimeoutReset $item
        }
        {error} {
            # connection may have failed or been refused
            HandleConnectionError $item [lindex $httpState(error) 0]
        }
    }

    # check if all transfers of this item are finished
    if {[dict get $RemainingTransfers $name] == 0} {
        eval $OnItemFinishedCmd [list $name [dict get $StateBuffer $name]]

        dict unset StateBuffer $name

        ${Log}::notice "progress: [dict size $StateBuffer]/[dict get \
                $Statistics "items"] items left"
    }

    http::cleanup $token

    ManageTransfers

    return
}

# control certificate verification and log errors during TLS handshake
proc ::relmon::crawler::OnTlsHandshake {type args} {
    variable Config
    variable Log

    switch -- ${type} {
        {error} {
            lassign $args {} tlsErrorMsg
            ${Log}::error "TLS connection error: $tlsErrorMsg"
        }
        {verify} {
            lassign $args {} {} {} status tlsErrorMsg
            array set cert [lindex $args 2]
            if {$status == 0} {
                if {[dict get $Config "ca_dir"] eq ""} {
                    # do not verify certificates is ca-dir was not set
                    return 1
                } else {
                    set errorMsg "$tlsErrorMsg\nCertificate details:"
                    foreach {key description} {"serial" "Serial Number"
                            "issuer" "Issuer" "notBefore" "Not Valid Before"
                            "notAfter" "Not Valid After" "subject" "Subject"
                            "sha1_hash" "SHA1 Hash"} {
                        append errorMsg "\n$description: $cert($key)"
                    }
                    ${Log}::error "TLS connection error: $errorMsg"
                    return 0
                }
            }
        }
    }
}

proc ::relmon::crawler::crawl {config watchlist log onItemFinishedCmd} {
    variable Config $config
    variable Watchlist $watchlist
    variable Queue
    variable Statistics
    variable Log $log
    variable OnItemFinishedCmd $onItemFinishedCmd
    variable Status
    variable RemainingTransfers
    variable StateBuffer

    # initialize queue and state buffer from the watchlist
    set Queue [dict create]
    dict for {name watchlistItem} $Watchlist {
        dict lappend Queue [::relmon::common::urlGetHost \
                [dict get $watchlistItem "base_url"]] \
                [dict create \
                "name" $name \
                "url" [dict get $watchlistItem "base_url"] \
                "pattern_index" 0 \
                "content_type" "" \
                "num_redirects" 0 \
                "num_retries" 0]
        dict set RemainingTransfers $name 1
        dict incr Statistics "items"
        dict set StateBuffer $name [dict create "versions" [dict create] \
                "errors" [list] "urls" [dict create]]
    }

    # configure http and tls
    http::register https 443 [list tls::socket \
            -cadir [dict get $Config "ca_dir"] -request 1 -require 1 \
            -command [namespace code OnTlsHandshake] -ssl2 0 -ssl3 1 -tls1 1]
    http::config -useragent "Mozilla/5.0 (Windows NT 6.1; rv:16.0)\
            Gecko/20100101 Firefox/16.0 relmon/$relmon::VERSION"

    # handle errors while in the event loop
    interp bgerror {} [namespace code OnError]

    dict set Statistics "start_time" [clock milliseconds]

    # enter the main loop
    after idle [namespace code ManageTransfers]
    vwait [namespace which -variable Status]

    # display statistics
    dict set Statistics "end_time" [clock milliseconds]
    ${Log}::notice "items checked: [dict get $Statistics "items"]"
    ${Log}::notice "time elapsed: [expr {([dict get $Statistics "end_time"] -
        [dict get $Statistics "start_time"]) / 1000}]s"

    return $Status
}


namespace eval ::relmon::update {
    # commandline option help text
    variable usage "usage: relmon update \[-dev\] \[-c max_connections\]\
            \[-C ca_dir\] \[-D host_delay\]\n\
            \                    \[-H max_connections_per_host\]\
            \[-i item_list\]\n\
            \                    \[-l logfile\] \[-r retries\]\
            \[-t before_seconds\]\n\
            \                    \[-T timeout_seconds\] watchlist statefile"

    # configuration options
    variable Config [dict create \
            "log_file" "" \
            "log_level" "notice" \
            "history_limit" 20 \
            "connection_limit" 16 \
            "host_connection_limit" 4 \
            "transfer_time_limit" 60000 \
            "retry_limit" 3 \
            "host_delay" 500 \
            "host_delays" [dict create] \
            "timestamp_filter" 0 \
            "error_filter" 0 \
            "item_filter" {} \
            "ca_dir" "" \
            "state_file" "" \
            "watchlist_file" ""]

    # watchlist
    variable Watchlist

    # logger handle
    variable Log

    # logfile handle
    variable Lf
}

proc ::relmon::update::OnItemFinished {name stateItem} {
    variable State
    variable Log
    variable Config

    set timestamp [clock milliseconds]

    # create httpState item if it does not exist yet
    if {![dict exists $State $name]} {
        dict set State $name [dict create "versions" [dict create] \
                "history" [list] "timestamp" 0 "errors" [list]]
    }

    # if there are no versions, log an error message since something must
    # be wrong
    if {[llength [dict get $stateItem "versions"]] == 0} {
        set warningMsg "\"$name\": no versions found"
        ${Log}::warn $warningMsg
        dict lappend stateItem "errors" $warningMsg
    }

    # update httpState item
    dict set State $name "errors" [dict get $stateItem "errors"]
    dict set State $name "timestamp" $timestamp
    if {[llength [dict get $stateItem "errors"]] == 0} {
        # expire old history entries
        set history [lrange [dict get $State $name "history"] \
                [expr {[llength [dict get $State $name "history"]] -
                [dict get $Config "history_limit"] + 1}] end]

        # add currently latest available version to history if it is either
        # newer than the previous one or if the previous one is no longer
        # available (e.g. if it has been removed or the watchlist pattern
        # has been changed)
        set prevLatestVersion [lindex $history end 0]
        set curLatestVersion [lindex \
                [lsort -command ::relmon::common::cmpVersion \
                [dict keys [dict get $stateItem "versions"]]] end]
        if {([::relmon::common::cmpVersion $curLatestVersion \
                $prevLatestVersion] > 0) ||
                ![dict exists $stateItem "versions" $prevLatestVersion]} {
            lappend history [list $curLatestVersion $timestamp]
            dict set State $name "history" $history
        }
        dict set State $name "versions" [dict get $stateItem "versions"]
    }
}

proc ::relmon::update::CleanupBeforeExit {commandString op} {
    variable Lf

    # close logfile
    if {($Lf ne "") && ($Lf ni {stdin stderr})} {
        close $Lf
        set Lf ""
    }

    return
}

proc ::relmon::update::main {args} {
    variable Config
    variable usage
    variable State
    variable Log
    variable Lf ""

    # parse commandline
    while {[set GetoptRet [cmdline::getopt args \
            {c.arg C.arg d D.arg e H.arg i.arg l.arg r.arg t.arg T.arg v} \
            OptArg OptVal]] == 1} {
        switch -glob -- $OptArg {
            {c} {
                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "host_connection_limit" $OptVal
            }
            {C} {
                if {![file isdirectory $OptVal]} {
                    puts stderr "directory \"$OptVal\" is not a directory"
                    exit 1
                } elseif {![file readable $OptVal] ||
                        ![file executable $OptVal]} {
                    puts stderr "directory \"$OptVal\" is not readable"
                    exit 1
                }
                dict set Config "ca_dir" $OptVal
            }
            {d} {
                dict set Config "log_level" "debug"
            }
            {D} {
                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "host_delay" [expr {$OptVal * 1000}]
            }
            {e} {
                dict set Config "error_filter" 1
            }
            {H} {
                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "connection_limit" $OptVal
            }
            {i} {
                foreach item [split $OptVal " "] {
                    set item [string trim $item]
                    if {$item ne ""} {
                        dict lappend Config "item_filter" $item
                    }
                }
            }
            {l} {
                dict set Config "log_file" $OptVal
                set LogDir [file dirname $OptVal]
                if {![file writable $LogDir] || ![file executable $LogDir]} {
                    puts stderr "directory \"$LogDir\" is not writable"
                    exit 1
                }
            }
            {r} {
                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "retry_limit" $OptVal
            }
            {t} {
                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "timestamp_filter" [expr {$OptVal * 1000}]
            }
            {T} {
                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "transfer_time_limit" [expr {$OptVal * 1000}]
            }
            {v} {
                if {[dict get $Config "log_level"] ne "debug"} {
                    dict set Config "log_level" "info"
                }
            }
        }
    }
    set argc [llength $args]
    if {$GetoptRet == -1} {
        puts stderr "unknown command line option \"-$OptArg\""
        puts stderr $usage
        exit 1
    }
    if {$argc != 2} {
        puts stderr $usage
        exit 1
    }
    dict set Config "watchlist_file" [lindex $args 0]
    if {![file readable [dict get $Config "watchlist_file"]]} {
        puts stderr "watchlist file \"[dict get $Config "watchlist_file"]\"\
                could not be read"
        exit 1
    }
    set stateFile [lindex $args 1]
    dict set Config "state_file" $stateFile
    set StateDir [file dirname $stateFile]
    if {![file writable $StateDir]} {
        puts stderr "directory \"$StateDir\" is not writable"

        exit 1
    }

    # install exit handler for closing the logfile, open the logfile and
    # initialize logger
    trace add execution exit enter CleanupBeforeExit
    if {[dict get $Config "log_file"] ne ""} {
        try {
            set Lf [open [dict get $Config "log_file"] "w"]
        } trap {POSIX} {errorMsg errorOptions} {
            puts stderr "failed to open logfile\
                    \"[dict get $Config "log_file"]\": $errorMsg"
            exit 1
        }
    } else {
        set Lf stderr
    }
    set Log [logger::init global]
    if {[dict get $Config "log_level"] eq "debug"} {
        set logFormat $relmon::LogFormatDebug
    } else {
        set logFormat $relmon::LogFormatDefault
    }
    logger::utils::applyAppender -appender fileAppend -appenderArgs \
            [list -outputChannel $Lf -conversionPattern $logFormat] \
            -serviceCmd $Log

    # set default logging level
    ${Log}::setlevel [dict get $Config "log_level"]

    ${Log}::notice "relmon.tcl starting up"

    # parse the watchlist
    try {
        set Watchlist [relmon::common::parseWatchlist \
                [dict get $Config "watchlist_file"]]
    } trap {POSIX} {errorMsg errorOptions} - \
    trap {RELMON} {errorMsg errorOptions} {
        ${Log}::error $errorMsg
        exit 1
    }

    # read the state file
    try {
        set State [::relmon::common::parseStateFile $stateFile]
    } trap {POSIX ENOENT} {errorMsg} {
        ${Log}::debug "state file \"$stateFile\" does not exist"
        set State [dict create]
    } trap {POSIX} {errorMsg} - \
    trap {RELMON} {errorMsg} {
        ${Log}::error $errorMsg
        exit 1
    }

    # apply filters specified on the command line to watchlist items
    set currentTime [clock milliseconds]
    dict for {name watchlistItem} $Watchlist {
        if {(([llength [dict get $Config "item_filter"]] > 0) &&
                ($name ni [dict get $Config "item_filter"])) ||
                ([dict get $Config "error_filter"] &&
                [dict exists $State $name "errors"] &&
                ([llength [dict get $State $name "errors"]] == 0)) ||
                ([dict exists $State $name "timestamp"] &&
                ([dict get $State $name "timestamp"] > $currentTime -
                [dict get $Config "timestamp_filter"]))} {
            dict unset Watchlist $name
        }
    }

    set ExitStatus [relmon::crawler::crawl $Config $Watchlist $Log \
            [namespace code OnItemFinished]]

    # serialize the new state
    set JsonStateItems {}
    dict for {item data} $State {
        set versions {}
        dict for {version url} [dict get $data "versions"] {
            lappend versions $version [json::write string $url]
        }
        set history {}
        foreach historyItem [dict get $data "history"] {
            lassign $historyItem version timestamp
            lappend history [json::write array [json::write string $version] \
                    $timestamp]
        }
        set errors {}
        foreach errorItem [dict get $data "errors"] {
            lappend errors [json::write string $errorItem]
        }
        lappend JsonStateItems $item [json::write object \
            "versions" [json::write object {*}$versions] \
            "history" [json::write array {*}$history] \
            "timestamp" [dict get $data "timestamp"] \
            "errors" [json::write array {*}$errors]]
    }
    set JsonState [json::write object {*}$JsonStateItems]

    # try to preserve permissions and ownership
    try {
        set stateFileAttributes [file attributes $stateFile]
    } trap {POSIX ENOENT} {} {
        set stateFileAttributes {}
    } trap {POSIX} {errorMsg errorOptions} {
        ${Log}::error "failed to stat \"$stateFile\": $errorMsg"
    }
    # write the new state to a temporary file
    set tmpFile "$stateFile.[pid].tmp"
    try {
        set f [open $tmpFile {RDWR CREAT EXCL TRUNC} 0600]
    } trap {POSIX} {errorMsg errorOptions} {
        ${Log}::error "failed to open \"$tmpFile\": $errorMsg"

        exit 1
    }
    try {
        chan puts -nonewline $f $JsonState
    } trap {POSIX} {errorMsg errorOptions} {
        catch {file delete $tmpFile}

        ${Log}::error "failed to write to \"$tmpFile\": $errorMsg"

        exit 1
    } finally {
        close $f
    }
    # make a backup of the previous state file
    try {
        file copy -force $stateFile "$stateFile~"
    } trap {POSIX ENOENT} {} {
        # ignore non-existing file
    } trap {POSIX} {errorMsg errorOptions} {
        ${Log}::error "failed to create a backup of \"$statFile\":\
                $errorMsg"
    }
    # rename the temporary file to the state file name
    try {
        file rename -force $tmpFile $stateFile
    } trap {POSIX} {errorMsg errorOptions} {
        catch {file delete $tmpFile}

        ${Log}::error "failed to rename \"$tmpFile\" to \"$stateFile\":\
                $errorMsg"

        exit 1
    }
    # restore ownership and permissions
    try {
        file attributes $stateFile {*}$stateFileAttributes
    } trap {POSIX} {errorMsg errorOptions} {
        ${Log}::error "failed to set permissions and ownership on\
                \"$stateFile\": $errorMsg"

        exit 1
    }

    # clean up
    ${Log}::delete

    exit $ExitStatus
}


namespace eval ::relmon::show {
    # commandline option help text
    variable usage "usage: relmon show statefile name..."
}

proc ::relmon::show::GetItem {stateName name} {
    upvar 1 $stateName state
    set item [dict get $state $name]

    # format state data as plain-text
    set output ""
    append output "Name: $name\n"
    append output "Latest Version:\
            [lindex [lindex [dict get $item "history"] end] 0]\n"
    append output "Refreshed: [clock format \
            [expr {[dict get $item "timestamp"] / 1000}] \
            -format {%Y-%m-%dT%H:%M:%S%z}]\n"
    append output "Versions:\n"
    dict for {version url} [dict get $item "versions"] {
        append output "\t$version $url\n"
    }
    append output "Errors:\n"
    if {[dict get $item "errors"] eq ""} {
        append output "\tNone\n"
    } else {
        foreach errorMsg [dict get $item "errors"] {
            append output "\t[string map {\n \n\t} [string trim $errorMsg]]\n"
        }
    }
    append output "History:\n"
    foreach historyItem [dict get $item "history"] {
        append output "\t[lindex $historyItem 0] [clock format \
                [expr {[lindex $historyItem 1] / 1000}] \
                -format {%Y-%m-%dT%H:%M:%S%z}]\n"
    }
    return $output
}

proc ::relmon::show::main {args} {
    variable usage

    # parse commandline
    if {[cmdline::getopt args {} OptArg OptVal] == -1} {
        puts stderr "unknown command line option \"-$OptArg\""
        puts stderr $usage
        exit 1
    }
    if {[llength $args] < 2} {
        puts stderr $usage
        exit 1
    }
    set stateFile [lindex $args 0]
    set names [lrange $args 1 end]

    try {
        set state [::relmon::common::parseStateFile $stateFile]
    } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
        puts stderr $errorMsg
        exit 1
    }

    # show each item
    foreach name $names {
        puts -nonewline [GetItem state $name]
    }

    exit 0
}


namespace eval ::relmon::list {
    # commandline option help text
    variable usage "usage: relmon list \[-H\] \[-f html|parseable|text\]\
            \[-F url\]\n\
            \                  \[-n number_items\] statefile\n\
            \      relmon list -f atom -F url \[-n number_items\] statefile"

    # configuration options
    variable Config [dict create \
            "format" "text" \
            "show_history" 0 \
            "history_limit" 100 \
            "feed_url" ""]
}

proc ::relmon::list::FormatText {stateName includeHistory historyLimit} {
    upvar 1 $stateName state
    set output ""
    append output [format "%-35s %-15s %-24s %-3s\n" "Project" "Version" \
            "Refreshed" "St."]
    append output [string repeat "-" 80]
    append output "\n"

    set history {}
    dict for {name item} $state {
        foreach historyItem [dict get $item "history"] {
            lappend history [list [lindex $historyItem 1] $name \
                    [lindex $historyItem 0]]
        }
        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
        set timestamp [clock format [expr {[dict get $item "timestamp"] /
                1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
        set status [expr {[llength [dict get $item "errors"]] > 0 ? "E" : ""}]
        append output [format "%-35s %15s %-24s %-1s\n" $name $latestVersion \
                $timestamp $status]
    }
    if {$includeHistory} {
        append output "\nHistory\n"
        append output [string repeat "-" 80]
        append output "\n"
        set history [lsort -decreasing -integer -index 0 $history]
        foreach historyItem [lrange $history 0 $historyLimit] {
            append output [format "%-24s %-35s %15s\n" \
                    [clock format [expr {[lindex $historyItem 0] / 1000}] \
                    -format {%Y-%m-%dT%H:%M:%S%z}] [lindex $historyItem 1] \
                    [lindex $historyItem 2]]
        }
    }

    return $output
}

proc ::relmon::list::FormatParseable {stateName includeHistory historyLimit} {
    upvar 1 $stateName state
    set output ""
    set history {}
    dict for {name item} $state {
        foreach historyItem [dict get $item "history"] {
            lappend history [list [lindex $historyItem 1] $name \
                    [lindex $historyItem 0]]
        }
        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
        if {$latestVersion eq ""} {
            set latestVersion -
        }
        set timestamp [clock format [expr {[dict get $item "timestamp"] /
                1000}] -timezone :UTC -format {%Y-%m-%dT%H:%M:%SZ}]
        set status [expr {[llength [dict get $item "errors"]] > 0 ? "ERROR" :
                "OK"}]
        append output [format "%s\t%s\t%s\t%s\n" $name $latestVersion \
                $timestamp $status]
    }
    if {$includeHistory} {
        append output "\n"
        set history [lsort -decreasing -integer -index 0 $history]
        foreach historyItem [lrange $history 0 $historyLimit] {
            append output [format "%s\t%s\t%s\n" [clock format \
                    [expr {[lindex $historyItem 0] / 1000}] -timezone :UTC \
                    -format {%Y-%m-%dT%H:%M:%SZ}] [lindex $historyItem 1] \
                    [lindex $historyItem 2]]
        }
    }
    return $output
}

proc ::relmon::list::FormatHtml {stateName includeHistory historyLimit
        feedUrl} {
    upvar 1 $stateName state

    set output "<html>\n"
    append output "<head>\n"
    append output "<title>Current Releases</title>\n"
    if {$feedUrl ne ""} {
        append output "<link type=\"application/atom+xml\" rel=\"alternate\"\
                title=\"Release History\"\
                href=\"[html::html_entities $feedUrl]\"/>\n"
    }
    append output "</head>\n"
    append output "<body>\n"
    append output "<h1>Current Releases</h1>\n<table>\n<tr>\n<th>Project</th>\
            \n<th>Version</th>\n<th>Refreshed</th>\n<th>Status</th>\n</tr>\n"
    set history {}
    dict for {name item} $state {
        foreach historyItem [dict get $item "history"] {
            lappend history [list [lindex $historyItem 1] $name \
                    [lindex $historyItem 0]]
        }
        set latestVersion [lindex [lindex [dict get $item "history"] end] 0]
        set timestamp [clock format [expr {[dict get $item "timestamp"] /
                1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
        set status [expr {[llength [dict get $item "errors"]] > 0 ? "Error" :
                "OK"}]

        append output "<tr>\n<td>[html::html_entities $name]</td>\n"
        if {$latestVersion ne ""} {
            if {[dict exists $item "versions" $latestVersion]} {
                set url [dict get $item "versions" $latestVersion]
                append output "<td><a\
                        href=\"[html::html_entities $url]\"\
                        title=\"[html::html_entities\
                        "$name $latestVersion"]\">[html::html_entities \
                        $latestVersion]</a></td>\n"
            } else {
                append output "<td>[html::html_entities \
                        $latestVersion]</td>\n"
            }
        } else {
            append output "<td></td>\n"
        }
        append output "<td>$timestamp</td>\n"
        append output "<td>[html::html_entities $status]</td>\n</tr>\n"
    }
    append output "</table>\n"

    if {$includeHistory} {
        set history [lsort -decreasing -integer -index 0 $history]
        append output "<h1>Release History</h1>\n<table>\n"
        append output "<tr><th>Time</th><th>Project</th><th>Version</th></tr>\n"
        foreach historyItem [lrange $history 0 $historyLimit] {
            set timestamp [clock format [expr {[lindex $historyItem 0] /
                    1000}] -format {%Y-%m-%dT%H:%M:%S%z}]
            set name [lindex $historyItem 1]
            set version [lindex $historyItem 2]
            append output "<tr>\n<td>$timestamp</td>\n"
            append output "<td>[html::html_entities $name]</td>\n"
            append output "<td>[html::html_entities $version]</td></tr>\n"
        }
        append output "</table>\n"
    }

    append output "</body>\n</html>\n"

    return $output
}

proc ::relmon::list::FormatAtom {stateName historyLimit feedUrl} {
    upvar 1 $stateName state
    set host [::relmon::common::urlGetHost $feedUrl]
    set output "<?xml version=\"1.0\" encoding=\"utf-8\"?>\
            \n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n"
    append output "<author><name>relmon</name></author>\n"
    append output "<title>Release History</title>\n"
    append output "<id>[html::html_entities $feedUrl]</id>\n"
    set history {}
    dict for {name item} $state {
        foreach historyItem [dict get $item "history"] {
            lappend history [list [lindex $historyItem 1] $name \
                    [lindex $historyItem 0]]
        }
    }
    set history [lsort -decreasing -integer -index 0 $history]
    set updated [lindex [lindex $history end] 0]
    if {$updated eq ""} {
        set updated [clock seconds]
    }
    append output "<updated>[clock format $updated \
            -format {%Y-%m-%dT%H:%M:%S%z}]</updated>\n"
    foreach historyItem [lrange $history 0 $historyLimit] {
        set name [lindex $historyItem 1]
        set version [lindex $historyItem 2]
        set timestamp [clock format [expr {[lindex $historyItem 0] / 1000}] \
                -format {%Y-%m-%dT%H:%M:%S%z}]
        set id "tag:$host,[clock format [lindex $historyItem 0] \
                -format {%Y-%m-%d}]:[uri::urn::quote $name-$version]"
        append output "<entry>\n"
        append output "<id>[html::html_entities $id]</id>\n"
        append output "<updated>$timestamp</updated>\n"
        append output "<title>[html::html_entities "$name $version"]</title>"
        append output "<content>[html::html_entities \
                "$name $version"]</content>\n"
        append output "</entry>\n"
    }
    append output "</feed>\n"
    return $output
}

proc ::relmon::list::main {args} {
    variable usage
    variable Config

    # parse commandline
    while {[set GetoptRet [cmdline::getopt args {f.arg F.arg H n.arg} OptArg \
            OptVal]] == 1} {
        switch -glob -- $OptArg {
            {f} {
                if {$OptVal ni {atom html parseable text}} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "format" $OptVal
            }
            {F} {
                if {[catch {dict create {*}[uri::split $OptVal]} UrlParts] ||
                        ([dict get $UrlParts "host"] eq "")} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "feed_url" $OptVal
            }
            {H} {
                dict set Config "show_history" 1
            }
            {n} {
                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "history_limit" [expr {$OptVal - 1}]
            }
        }
    }
    set argc [llength $args]
    if {$GetoptRet == -1} {
        puts stderr "unknown command line option \"-$OptArg\""
        puts stderr $usage
        exit 1
    }
    if {$argc != 1} {
        puts stderr $usage
        exit 1
    }
    if {([dict get $Config "format"] eq "atom") &&
            ([dict get $Config "feed_url"] eq "")} {
        puts stderr "mandatory \"-F\" option is missing"
        puts stderr $usage
        exit 1
    }
    set StateFile [lindex $args 0]

    # read the state file
    try {
        set State [::relmon::common::parseStateFile $StateFile]
    } trap {POSIX} {errorMsg} - trap {RELMON} {errorMsg} {
        puts stderr $errorMsg
        exit 1
    }

    # call formatter
    switch -- [dict get $Config "format"] {
        {atom} {
            puts -nonewline [FormatAtom State \
                    [dict get $Config "history_limit"] \
                    [dict get $Config "feed_url"]]
        }
        {html} {
            puts -nonewline [FormatHtml State \
                    [dict get $Config "show_history"] \
                    [dict get $Config "history_limit"] \
                    [dict get $Config "feed_url"]]
        }
        {parseable} {
            puts -nonewline [FormatParseable State \
                    [dict get $Config "show_history"] \
                    [dict get $Config "history_limit"]]
        }
        {default} {
            puts -nonewline [FormatText State \
                    [dict get $Config "show_history"] \
                    [dict get $Config "history_limit"]]
        }
    }

    exit 0
}


namespace eval ::relmon::help {
    # commandline option help text
    variable usage "usage: relmon help \[subcommand\]"
}

proc ::relmon::help::main {args} {
    variable usage

    # parse commandline
    if {[cmdline::getopt args {} OptArg OptVal] == -1} {
        puts stderr "unknown command line option \"-$OptArg\""
        puts stderr $usage
        exit 1
    }
    set argc [llength $args]
    if {$argc > 1} {
        puts stderr $usage
        exit 1
    }
    set subCommand [lindex $args 0]
    if {$subCommand ne ""} {
        if {[info procs ::relmon::${subCommand}::main] ne ""} {
            puts stderr [set ::relmon::${subCommand}::usage]
        } else {
            puts stderr "unknown subcommand \"$subCommand\""
            puts stderr $usage
            exit 1
        }
    } else {
        foreach subCommandNs [namespace children ::relmon] {
            if {[info procs ${subCommandNs}::main] ne ""} {
                puts stderr [set ${subCommandNs}::usage]
            }
        }
    }
    exit 0
}


namespace eval ::relmon::discover {
    # commandline option help text
    variable usage "usage: relmon discover \[-d\] \[-c max_connections\]\
            \[-C ca_dir\] \[-D host_delay\]\n\
            \                      \[-H max_connections_per_host\]\
            \[-r retries\]\n\
            \                      \[-t before_seconds\]\
            \[-T timeout_seconds\] base_url\n\
            \                      \[pattern...\]"

    # configuration options
    variable Config [dict create \
            "log_file" "" \
            "log_level" "info" \
            "connection_limit" 16 \
            "host_connection_limit" 4 \
            "transfer_time_limit" 60000 \
            "retry_limit" 3 \
            "host_delay" 500 \
            "host_delays" [dict create] \
            "ca_dir" ""]

    # transfer statistics
    variable Statistics [dict create \
            "start_time" [clock milliseconds] \
            "end_time" 0 \
            "requests" 0 \
            "items" 0]

    # watchlist
    variable Queue [dict create]

    # logger handle
    variable Log
}

proc ::relmon::discover::OnItemFinished {name stateItem} {
    variable Log

    dict for {url urls} [dict get $stateItem "urls"] {
        dict for {linkUrl matched} $urls {
            if {$matched} {
                puts "\"$url\": found matching URL \"$linkUrl\""
            } else {
                puts "\"$url\": found non-matching URL \"$linkUrl\""
            }
        }
    }
}

proc ::relmon::discover::main {args} {
    variable Config
    variable usage
    variable Log
    variable Queue

    # parse commandline
    while {[set GetoptRet [cmdline::getopt args \
            {c.arg C.arg d D.arg h H.arg r.arg t.arg T.arg ?} \
            OptArg OptVal]] == 1} {
        switch -glob -- $OptArg {
            {c} {
                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "host_connection_limit" $OptVal
            }
            {C} {
                if {![file isdirectory $OptVal]} {
                    puts stderr "directory \"$OptVal\" is not a directory"
                    exit 1
                } elseif {![file readable $OptVal] ||
                        ![file executable $OptVal]} {
                    puts stderr "directory \"$OptVal\" is not readable"
                    exit 1
                }
                dict set Config "ca_dir" $OptVal
            }
            {d} {
                dict set Config "log_level" "debug"
            }
            {D} {
                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "host_delay" $OptVal
            }
            {[h?]} {
                puts stderr $usage
                exit 0
            }
            {H} {
                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "connection_limit" $OptVal
            }
            {r} {
                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "retry_limit" $OptVal
            }
            {t} {
                if {![string is digit -strict $OptVal] || ($OptVal < 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "timestamp_filter" [expr {$OptVal * 1000}]
            }
            {T} {
                if {![string is digit -strict $OptVal] || ($OptVal <= 0)} {
                    puts stderr "invalid value passed to \"-$OptArg\""
                    exit 1
                }
                dict set Config "transfer_time_limit" [expr {$OptVal * 1000}]
            }
        }
    }
    set argc [llength $args]
    if {$GetoptRet == -1} {
        puts stderr "unknown command line option \"-$OptArg\""
        puts stderr $usage
        exit 1
    }
    if {$argc < 1} {
        puts stderr $usage
        exit 1
    }

    set patterns [lassign $args baseUrl]

    # validate URL
    if {![::relmon::common::isUrlValid $baseUrl]} {
        puts stderr "invalid base URL"
        exit 1
    }

    # process patterns
    set processedPatterns {}
    set reInfo {}
    set patternIndex 0
    foreach pattern $patterns {
        incr patternIndex

        # make trailing slashes optional
        if {($patternIndex != [llength $patterns]) &&
                ([string index $pattern end] eq "/")} {
            append pattern {?}
        }

        # ensure patterns are anchored to the end of the line
        if {[string index $pattern end] ne "$"} {
            append pattern {$}
        }

        # actually validate the regular expression
        try {
            set reInfo [regexp -about -- $pattern ""]
        } on error {errorMsg} {
            puts stderr $errorMsg
            exit 1
        }
        lappend processedPatterns $pattern
    }
    # add a dummy pattern "()" if the last pattern is does not contain a
    # capturing group, this will match every link and capture an empty string
    if {[lindex $reInfo 0] < 1} {
        lappend processedPatterns {()}
    }

    # construct a watchlist from the command line arguments
    set watchlist [dict create "new project" [dict create "base_url" $baseUrl \
            "patterns" $processedPatterns]]

    set Log [logger::init global]
    if {[dict get $Config "log_level"] eq "debug"} {
        set logFormat $relmon::LogFormatDebug
    } else {
        set logFormat $relmon::LogFormatDefault
    }
    logger::utils::applyAppender -appender fileAppend -appenderArgs \
            [list -outputChannel stderr -conversionPattern $logFormat] \
            -serviceCmd $Log

    # set default logging level
    ${Log}::setlevel [dict get $Config "log_level"]

    ${Log}::notice "relmon.tcl starting up"

    set ExitStatus [relmon::crawler::crawl $Config $watchlist $Log \
            [namespace code OnItemFinished]]

    exit $ExitStatus
}


proc ::relmon::main {args} {
    variable usage
    set subArgs [lassign $args subCommand]

    # generate list of subcommands
    set subCommands {}
    foreach subCommandNs [namespace children ::relmon] {
        if {[info procs ${subCommandNs}::main] ne ""} {
            lappend subCommands [namespace tail $subCommandNs]
        }
    }
    if {$subCommand ni $subCommands} {
        if {$subCommand ne ""} {
            puts stderr "unknown subcommand \"$subCommand\""
        }
        foreach command $subCommands {
            puts stderr [set relmon::${command}::usage]
        }
        exit 1
    }

    # dispatch subcommand
    relmon::${subCommand}::main {*}$subArgs
}


relmon::main {*}$argv