#!/usr/bin/env tclsh

# $Id: owside.tcl,v 1.2 2008/04/18 14:08:47 alfille Exp $

package require Tk

# Global: IPAddress() loose tap server
# -- port number of this program (tap) and real owserver (server). loose is stray garbage

set SocketVars {string tapversion taphost tappeer version type payload size sg offset tokenlength totallength paylength typetext ping state sock versiontext flagtext persist return id taptype }

set MessageList {ERROR NOP READ WRITE DIR SIZE PRESENCE DIRALL GET}
set MessageListPlus $MessageList
lappend MessageListPlus PING BadHeader Unknown Total

# see http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html
set HttpList [list "GET " POST HEAD CONN "PUT " DELE TRAC]

set stats(clientlist) {}
set setup_flags(detail_list) {}

# Global: setup_flags => For object-oriented initialization

# Global: serve => information on current transaction
#         serve($sock.string) -- message to this point
#         serve($sock. version size payload sg offset type tokenlength ) -- message parsed parts
#         serve($sock.version size
#         serve(sockets) -- list of active sockets for timeout

# Global: stats => statistical counts and flags for stats windows

# Global: circ_buffer => data for the last n transactions displayed in the listboxes

# Global: cross_buffer -> takes taphost:tappeer to circ_buffer index

#Main procedure. We actually start it at the end, to allow Proc-s to be defined first.
proc Main { argv } {
    ArgumentProcess

    tk_messageBox -message "Still under development."  -icon warning -type ok -title "owside"

    CircBufferSetup 50
    DisplaySetup
    StatsSetup

    SetupSide
}

# Command line processing
# looks at command line arguments
# two options "p" and "s" for (this) tap's _p_ort, and the target ow_s_erver port
# Can handle command lines like
# -p 3000 -s 3001
# -p3000 -s 3001
# etc
proc ArgumentProcess { } {
    global IPAddress
    set mode "loose"
    # "Clear" ports
    # INADDR_ANY
    # tk_messageBox -message "$::argv" -type ok
    set IPAddress(tap.ip) "0.0.0.0"
    set IPAddress(tap.port) "4305"
    foreach a $::argv {
	if { [regexp -- {^-p(.*)$} $a whole address] } {
	    set mode "tap"
	} elseif { [regexp -- {^-s(.*)$} $a whole address] } {
	    set mode "tap"
	}  else {
	    set address $a
	}
	IPandPort $address
    }
    MainTitle $IPAddress(tap.ip):$IPAddress(tap.port)
}

proc IPandPort { argument_string } {
    global IPAddress
    if { [regexp -- {^(.*?):(.*)$} $argument_string wholestring firstpart secondpart] } {
	if { $firstpart != "" } {
	    set IPAddress(tap.ip) $firstpart
	}
	if { $secondpart != "" } {
	    set IPAddress(tap.port) $secondpart
	}
    } else {
	if { $argument_string != "" } {
	    set IPAddress(tap.port) $argument_string
	}
    }
}

# Accept from client (our "server" portion)
proc SetupSide { } {
    global IPAddress
    StatusMessage "Attempting to open sidetap server on $IPAddress(tap.ip):$IPAddress(tap.port)"
    if {[catch {socket -server SideAccept -myaddr $IPAddress(tap.ip) $IPAddress(tap.port)} result] } {
        ErrorMessage $result
    }
    StatusMessage "Success. Sidetap server address=[PrettySock $result]"
    MainTitle [PrettySock $result]
}

#Main loop. Called whenever the server (listen) port accepts a connection.
proc SideAccept { sock addr port } {
    global serve
    global stats

    # Start the State machine
    set serve($sock.state) "Open owserver"
    while {1} {
	puts $serve($sock.state)
	switch $serve($sock.state) {
	    "Open owserver" {
		StatusMessage "Reading client request from $addr port $port" 0
		set persist 0
		if { [catch {fconfigure $sock -buffering full -translation binary -encoding binary -blocking 0} result] } {
		    StatusMessage "Socket $sock closed."
		    return
		}
		set serve($sock.state) "Persistent loop"
	    }
	    "Persistent loop" {
		TapSetup $sock
		set serve($sock.sock) $sock
		set serve($sock.state) "Read owserver"
	    }
	    "Read owserver" {
		# wait a long time (3hr) for very first packet
		ResetSockTimer $sock 10000000
		fileevent $sock readable [list TapProcess $sock]
		#   ShowMessage $sock
		vwait serve($sock.state)
	    }
	    "Process any packet" {
		StatusMessage "Reading owserver packet from $addr port $port" 0
		puts $serve($sock.taptype)
		switch $serve($sock.taptype) {
		    "client" {
			set serve($sock.state) "Process client packet"
		    }
		    "server" {
			set serve($sock.state) "Process server packet"
		    }
		    default {
			set serve($sock.state) "Open owserver"
		    }
		}
	    }
	    "Process client packet" {
		fileevent $sock readable {}
		ClearSockTimer $sock
		StatusMessage "Success reading client request" 0
		set message_type $serve($sock.typetext)
		CircBufferEntryRequest "$addr:$port $message_type $serve($sock.payload) bytes" $serve($sock.string)
		AddClient $addr:$port
		#stats
		RequestStatsIncr $sock 0
		# now owserver
		set serve($sock.state) "Persistent loop"
	    }
	    "Process server packet" {
		StatusMessage "Success reading OWSERVER response" 0
		CircBufferEntryResponse $serve($sock.return) $serve($sock.string)
		#stats
		ResponseStatsIncr $sock 0
		set serve($sock.state) "Analyze response"
	    }
	    "Web client" {
		StatusMessage "Error: owtap is not a web server"
		RequestStatsIncr $sock 1
		WebResponse $sock
		CloseSock $sock
		StatusMessage "Ready" 0
		return
	    }
	    "Early end" {
		StatusMessage "Reading owserver packet from $addr port $port" 0
		switch $serve($sock.taptype) {
		    "client" {
			set serve($sock.state) "Client early end"
		    }
		    "server" {
			set serve($sock.state) "Server early end"
		    }
		    default {
			set serve($sock.state) "Open owserver"
		    }
		}
	    }
	    "Client early end" {
		StatusMessage "FAILURE reading client request"
		CircBufferEntryRequest "network read error" $serve($sock.string)
		RequestStatsIncr $sock 1
		set serve($sock.state) "Open owserver"
	    }
	    "Server early end" {
		StatusMessage "FAILURE reading OWSERVER response" 0
		ResponseStatsIncr $sock 1
		CircBufferEntryResponse "network read error" $serve($sock.string)
		set serve($sock.state) "Open owserver"
	    }
	    "Analyze response" {
		if { $serve($sock.ping) == 1 } {
		    set serve($sock.state) "Ping received"
		} elseif { ( $message_type=="DIR" ) && ($serve($sock.paylength)>0)} {
		    set serve($sock.state) "Dir element received"
		} else {
		    set serve($sock.state) "Persistent test"
		}
	    }
	    "Ping received" {
		set serve($sock.state) "Read owserver"
	    }
	    "Dir element received" {
		set serve($sock.state) "Read owserver"
	    }
	    "Persistent test" {
		if { $serve($sock.persist)==1 } {
		    StatPersistCounter $persist
		    incr persist
		    ClearTap $sock
		    set serve($sock.state) "Persistent loop"
		} else {
		    set serve($sock.state) "Open owserver"
		}
	    }
	    "Server timeout" {
		StatusMessage "OWSERVER timeout" 0
		set serve($sock.state) "Open owserver"
	    }
	    "Client timeout" {
		StatusMessage "Client timeout" 0
		set serve($sock.state) "Open owserver"
	    }
	    default {
		StatusMessage "Internal error -- bad state: $serve($sock.state)" 1
		return
	    }
	}
    }
}

# initialize statistics
proc StatsSetup { } {
    global stats
    global MessageListPlus
    foreach x $MessageListPlus {
	set stats($x.tries) 0
	set stats($x.errors) 0
	set stats($x.rate) 0
	set stats($x.request_bytes) 0
	set stats($x.response_bytes) 0
    }
    foreach x { request_yes request_no grant refuse -1 0 denominator max request_rate grant_rate } {
        set stats(persistence_length.$x) 0
    }
    set stats(persistence_length.15plus) 0
}

# increment stats for  request
proc RequestStatsIncr { sock is_error} {
    global stats
    global serve
    set message_type $serve($sock.typetext)
    set length [ expr {[string length $serve($sock.string) ] - 244} ]

    incr stats($message_type.tries)
    incr stats($message_type.errors) $is_error
    set stats($message_type.rate) [expr {100 * $stats($message_type.errors) / $stats($message_type.tries)} ]
    incr stats($message_type.request_bytes) $length

    incr stats(Total.tries)
    incr stats(Total.errors) $is_error
    set stats(Total.rate) [expr {100 * $stats(Total.errors) / $stats(Total.tries)} ]
    incr stats(Total.request_bytes) $length

    # persistence stats
    if { [info exist serve($sock.persist)] } {
	if { $serve($sock.persist) == 0 } {
	    incr stats(persistence_length.request_no)
	} else {
	    incr stats(persistence_length.request_yes)
	    incr stats(persistence_length.refuse)
	    set stats(persistence_length.grant_rate) [expr {100 * $stats(persistence_length.grant) / $stats(persistence_length.request_yes)}]
	}
	set stats(persistence_length.request_rate) [expr { 100 * $stats(persistence_length.request_yes) / $stats(Total.tries) }]
    }
}

# increment stats for  request
proc ResponseStatsIncr { sock is_error} {
    global stats
    global serve
    set message_type $serve($serve($sock.sock).typetext)
    set length [ expr { [string length $serve($sock.string) ] - 244} ]
    
    if { $stats($message_type.tries) == 0 } {
        return
    }

    incr stats($message_type.errors) $is_error
    set stats($message_type.rate) [expr {100 * $stats($message_type.errors) / $stats($message_type.tries)} ]
    incr stats($message_type.response_bytes) $length

    incr stats(Total.errors) $is_error
    set stats(Total.rate) [expr {100 * $stats(Total.errors) / $stats(Total.tries)} ]
    incr stats(Total.response_bytes) $length
}

# Counter of Persistence lengths
proc StatPersistCounter { persist } {
    global stats
    # max persistence length
    if { $persist > $stats(persistence_length.max) } {
	set stats(persistence_length.max) $persist
	set stats(persistence_length.$persist) 0
    }
    # increment this bin (and decrement prior)
    if { $persist==0 } {
        incr stats(persistence_length.denominator)
    }
    set old_persist [expr {$persist-1}]
    incr stats(persistence_length.$old_persist) -1
    if { $persist == 16 } {
        incr stats(persistence_length.15plus)
    }
    incr stats(persistence_length.$persist)
    incr stats(persistence_length.grant)
    incr stats(persistence_length.refuse) -1
    set stats(persistence_length.grant_rate) [expr {100 * $stats(persistence_length.grant) / $stats(persistence_length.request_yes)}]

    set length_sum 0
    for {set x 0} {$x <= $stats(persistence_length.max)} {incr x} {
        incr length_sum [expr {$stats(persistence_length.$x) * $x}]
    }
    set stats(persistence_length.mean) [expr {($length_sum)/$stats(persistence_length.denominator)}]
}


# Initialize array for client request
proc TapSetup { sock } {
    global serve
    set serve($sock.string) ""
    set serve($sock.totallength) 0
}

# Clear out client request array after a connection (frees memory)
proc ClearTap { sock } {
    global serve
    global SocketVars
    foreach x $SocketVars {
	if { [info exist serve($sock.$x)] } {
	    unset serve($sock.$x)
	}
    }
    if { [info exist serve($sock.num] } {
	for {set i $serve($sock.num)} {$i >= 0} {incr i -1} {
	    unset serve($sock.$i)
	}
        unset serve($sock.num)
    }
}

proc ResponseAdd { sock } {
    global serve
    if { [info exist serve($sock.num)] } {
        incr serve($sock.num)
    } else {
        set serve($sock.num) 0
    }
    set serve($sock.$serve($sock.num)) $serve($sock.string)
}

# close client request socket
proc SockTimeout { sock } {
    global serve
    switch $serve($serve($sock.sock).state) {
	"Read owserver" {
	    set serve($serve($sock.sock).state) "Client timeout"
	}
	"Read from server" {
	    set serve($serve($sock.sock).state) "Server timeout"
	}
	default {
	    ErrorMessage "Strange timeout for $sock state=$serve($serve($sock.sock).state)"
	    set serve($serve($sock.sock).state) "Server timeout"
	}
    }
    StatusMessage "Network read timeout [PrettySock $sock]" 1
}

# close client request socket
proc CloseSock { sock } {
    global serve
    ClearSockTimer $sock
    close $sock
    ClearTap $sock
}

proc ClearSockTimer { sock } {
    global serve
    if { [info exist serve($sock.id)] } {
	after cancel $serve($sock.id)
	unset serve($sock.id)
    }
}

proc ResetSockTimer { sock { msec 2000 } } {
    global serve
    ClearSockTimer $sock
    set serve($sock.id) [after $msec [list SockTimeout $sock ]]
}

# Wrapper for processing -- either change a vwait var, or just return waiting for more network traffic
proc TapProcess { sock } {
    global serve
    set read_value [ReadProcess $sock]
    switch $read_value {
	"Web client"  { set serve($sock.state) "Web client" }
	"Early end"  { set serve($sock.state) "Early end" }
	"Packet reloop"  { return }
	"Process packet"  { set serve($sock.state) "Process any packet" }
    }
    TypeParser serve $sock
}

# Process a oncomming owserver packet, adjusting size from header information
proc ReadProcess { sock } {
    global serve
    # test eof
    if { [eof $sock] } {
        return "Early end"
    }
    # read what's waiting
    set new_string [read $sock]
    if { $new_string == {} } {
        return "Packet reloop"
    }
    append serve($sock.string) $new_string
    ResetSockTimer $sock
    set len [string length $serve($sock.string)]
    if { $len < 268 } {
	# headers are 244 for sidetap header, 24 for owprotocol header
        #do nothing -- reloop
        return "Packet reloop"
    } elseif { $serve($sock.totallength) == 0 } {
        # Look for web browser
        global HttpList
        if { [lsearch -exact $HttpList [string range $serve($sock.string) 0 3]] >= 0 } {
            return "Web client"
        }
        # at least header is in
        HeaderParser serve $sock $serve($sock.string)
    }
    #already in payload (and token) portion
    if { $len < $serve($sock.totallength) } {
	#do nothing -- reloop
	return "Packet reloop"
    }
    # Fully parsed
    set new_length [string length $serve($sock.string)]
    return "Process packet"
}

# Debugging routine -- show all the packet info
proc ShowMessage { sock } {
    global serve
    global SocketVars
    foreach x $SocketVars {
	if { [info exist serve($sock.$x)] } {
	    puts "\t$sock.$x = $serve($sock.$x)"
	}
    }
}

# callback from scrollbar, moves each listbox field
proc ScrollTogether { args } {
    eval {.log.request_list yview} $args
    eval {.log.response_list yview} $args
}

# scroll other listbox and scrollbar
proc Left_ScrollByKey { args } {
    eval { .log.transaction_scroll set } $args
    .log.response_list yview moveto [lindex [.log.request_list yview] 0 ]
    .log.response_list activate [.log.request_list index active ]
}

# scroll other listbox and scrollbar
proc Right_ScrollByKey { args } {
    eval { .log.transaction_scroll set } $args
    .log.request_list yview moveto [lindex [.log.response_list yview] 0 ]
    .log.request_list activate [.log.response_list index active ]
}

# Selection from listbox
proc SelectionMade { widget y } {
    set index [ $widget nearest $y ]
    if { $index >= 0 } {
    TransactionDetail [current_from_index $index]
    }
}

# create visual aspects of program
proc DisplaySetup { } {
    global circ_buffer
    # Top pane, tranaction logs
    frame .log -bg yellow

    scrollbar .log.transaction_scroll -command [ list ScrollTogether ]
    label .log.request_title -text "Client request" -bg yellow -relief ridge
    label .log.response_title -text "Owserver response" -bg yellow -relief ridge
    listbox .log.request_list -width 40 -height 10 -selectmode single -yscroll [list Left_ScrollByKey ] -bg lightyellow
    listbox .log.response_list -width 40 -height 10 -selectmode single -yscroll [list Right_ScrollByKey] -bg lightyellow

    foreach lb {request_list response_list} {
	bind .log.$lb <ButtonRelease-1> {+ SelectionMade %W %y }
	bind .log.$lb <space> {+ SelectionMade %W }
    }

    grid .log.request_title -row 0 -column 0 -sticky news
    grid .log.response_title -row 0 -column 1 -sticky news
    grid .log.request_list -row 1 -column 0 -sticky news
    grid .log.response_list -row 1 -column 1 -sticky news
    grid .log.transaction_scroll -row 1 -column 2 -sticky news

    pack .log -side top -fill x -expand true

    #bottom pane, status
    label .status -anchor w -width 80 -relief sunken -height 1 -textvariable current_status -bg white
    pack .status -side bottom -fill x
    bind .status <ButtonRelease-1> [list .main_menu.view invoke "Status messages"]

    SetupMenu
}

# Menu construction
proc SetupMenu { } {
    global stats
#    toplevel . -menu .main_menu
    menu .main_menu -tearoff 0
    . config -menu .main_menu

    # file menu
    menu .main_menu.file -tearoff 0
    .main_menu add cascade -label File -menu .main_menu.file  -underline 0
    .main_menu.file add command -label "Log to File..." -underline 0 -command SaveLog -state disabled
    .main_menu.file add command -label "Stop logging" -underline 0 -command SaveAsLog -state disabled
    .main_menu.file add separator
    .main_menu.file add command -label "Restart" -underline 0 -command Restart
    .main_menu.file add separator
    .main_menu.file add command -label "Quit" -underline 0 -command exit

    # statistics menu
    menu .main_menu.view -tearoff 0
    .main_menu add cascade -label View -menu .main_menu.view  -underline 0
    .main_menu.view add checkbutton -label "Statistics by Message type" -underline 14 -indicatoron 1 -command {StatByType}
    .main_menu.view add checkbutton -label "Persistence rates" -underline 12 -indicatoron 1 -command {RatePersist}
    .main_menu.view add checkbutton -label "Persistence lengths" -underline 12 -indicatoron 1 -command {LengthPersist}
    .main_menu.view add separator
    .main_menu.view add checkbutton -label "Detail window list" -underline 0 -indicatoron 1 -command {DetailList}
    .main_menu.view add separator
    .main_menu.view add checkbutton -label "Clients" -underline 0 -indicatoron 1 -command {StatByClient}
    .main_menu.view add separator
    .main_menu.view add checkbutton -label "Status messages" -underline 0 -indicatoron 1 -command {StatusWindow}

    # help menu
    menu .main_menu.help -tearoff 0
    .main_menu add cascade -label Help -menu .main_menu.help  -underline 0
    .main_menu.help add command -label "About OWSIDE" -underline 0 -command About
    .main_menu.help add command -label "Command Line" -underline 0 -command CommandLine
    .main_menu.help add command -label "OWSERVER  Protocol" -underline 0 -command Protocol
    .main_menu.help add command -label "Version" -underline 0 -command Version
}

# error routine -- popup and exit
proc ErrorMessage { msg } {
    StatusMessage "Fatal error -- $msg"
    tk_messageBox -title "Fatal error" -message $msg -type ok -icon error
    exit 1
}

# status -- set status message
#   possibly store past messages
#   Use priority to test if should be stored
proc StatusMessage { msg { priority 1 } } {
    global current_status
    set current_status $msg
    if { $priority > 0 } {
	global status_messages
	lappend status_messages $msg
	if { [llength $status_messages] > 50 } {
	    set status_messages [lreplace $status_messages 0 0]
	}
    }
}

# Circular buffer for past connections
#   size is number of elements
proc CircBufferSetup { size } {
    global circ_buffer
    set circ_buffer(size) $size
    set circ_buffer(total) -1
}

# Save a spot for the coming connection
proc CircBufferAllocate { } {
    global circ_buffer
    set size $circ_buffer(size)
    incr circ_buffer(total)
    set total $circ_buffer(total)
    set cb_index [ expr { $total % $size } ]
    if { $total >= $size } {
	# delete top listbox entry (oldest)
	.log.request_list delete 0
	.log.response_list delete 0
	# clear old entry
	if { [info exist circ_buffer($cb_index.num)] } {
	    set num $circ_buffer($cb_index.num)
	    for {set x 0} { $x < $num } {incr x} {
		unset circ_buffer($cb_index.response.$x)
	    }
	}
    
	global current_to_pair
	global pair_to_current
	if { [ info exist current_to_pair($total)] } {
	    set sock_pair $current_to_pair($total)
	    if { [info exist pair_to_current($sock_pair) ] } {
		unset pair_to_current($sock_pair)
	    }
	    unset current_to_pair($total)
	}
    }
    set circ_buffer($cb_index.num) 0
    set circ_buffer($cb_index.request) ""
    .log.request_list insert end "$total: pending"
    .log.response_list insert end "$total: pending"
    return $total
}

# place a new request packet
proc CircBufferEntryRequest { request {transaction_string "" } } {
    global circ_buffer
    set size $circ_buffer(size)
    set total $circ_buffer(total)
    set current [CircBufferAllocate]
    
    # Still filling for the first time?
    if { $total < $size } {
        set index $current
    } else {
        set index [ expr $size - $total + $current - 1 ]
    }
    .log.request_list insert $index $request
    .log.request_list delete [expr $index + 1 ]

    #Now store packet
    set cb_index [ expr { $current % $size } ]
    set circ_buffer($cb_index.request) $transaction_string

    # get request data
    global current_to_pair
    global pair_to_current
    HeaderParser q x $transaction_string
    set sock_pair $q(x.taphost).$q(x.tappeer)
    if { [info exist pair_to_current($sock_pair)] } {
        set old_current $pair_to_current($sock_pair)
        if { [ info exist current_to_pair(old_current) ] && $current_to_pair($old_current) == $sock_pair } {
	    unset current_to_pair($old_current)
        }
    }
    set current_to_pair($current) $sock_pair
    set pair_to_current($sock_pair) $current
}

# place a new response packet
proc CircBufferEntryResponse { response {transaction_string "" } } {
    global circ_buffer
    
    global pair_to_current
    HeaderParser q x $transaction_string
    set sock_pair $q(x.taphost).$q(x.tappeer)
    if { ! [ info exists pair_to_current($sock_pair) ] } {
	StatusMessage "OWSERVER response without client request -- ignored" 0
	return
    }
    set current $pair_to_current($sock_pair)        
    
    set size $circ_buffer(size)
    set total $circ_buffer(total)
    if { [expr {$current + $size}] <= $total } {
	StatusMessage "Packet buffer history overflow. (nonfatal)" 0
	return
    }
    # Still filling for the first time?
    if { $total < $size } {
	set index $current
    } else {
	set index [ expr $size - $total + $current - 1 ]
    }
    .log.response_list insert $index "$current: $response"
    .log.response_list delete [expr $index + 1 ]
    
    #Now store packet
    set cb_index [ expr { $current % $size } ]
    set circ_buffer($cb_index.response.$circ_buffer($cb_index.num)) $transaction_string
    incr circ_buffer($cb_index.num)
}

# get the slot in the circ_buffer from the listbox index
proc cb_from_index { index } {
    global circ_buffer
    set size $circ_buffer(size)
    set total $circ_buffer(total)
    if { $total < $size } {
	return $index
    }
    return [expr { ($total + $index) % $size }]
}

# get the total list from listbox index
proc current_from_index { index } {
    global circ_buffer
    set size $circ_buffer(size)
    set total $circ_buffer(total)
    if { $total < $size } {
	return $index
    }
    return [expr { $total + $index - $size  + 1 }]
}

# Popup giving attribution
proc About { } {
    tk_messageBox -type ok -title {About owside} -message {
Program: owside
Synopsis: owserver protocol inspector

Description: owside receives a copy of
all owserver and client conversation.

The communication is logged and
shown on screen.

Clients are not affected by owside.

Author: Paul H Alfille <paul.alfille@gmail.com>

Copyright: July 2007 GPL 2.0 license

Website: http://www.owfs.org
    }
}

# Popup giving commandline
proc CommandLine { } {
    tk_messageBox -type ok -title {owtap command line} -message {
syntax: owside.tcl -p tapport

server port is the address of owserver
tapport is the port assigned this program

Usage (owdir example)

If owserver was invoked as:
    owserver -p 3000 -u
a client (say owdir) would normally call:
    owdir -s 3000 /

To use owtap, invoke it with
    owtap.tcl -s 3000 -p 4000
and now call owdir with:
    owdir -s 4000 /
    }
}

# Popup giving version
proc Version { } {
    regsub -all {[$:a-zA-Z]} {$Revision: 1.2 $} {} Version
    regsub -all {[$:a-zA-Z]} {$Date: 2008/04/18 14:08:47 $} {} Date
    tk_messageBox -type ok -title {owtap version} -message "
Version $Version
Date    $Date
    "
}

# Popup on protocol
proc Protocol { } {
    tk_messageBox -type ok -title {owserver protocol} -message {
The owserver protocol is a tcp/ip
protocol for communication between
owserver and clients.

It is recognized as a "well
known port" by the IANA (4304)
and has an associated mDNS
service (_owserver._tcp).

Details can be found at:
http://www.owfs.org/index.php?page=owserver-protocol
    }
}

# Show a list of detail windows
proc DetailList { } {
    set window_name .detaillist
    set menu_name .main_menu.view
    set menu_index "Detail window list"

    if { [ WindowAlreadyExists $window_name $menu_name $menu_index ] } {
      return
    }

    global setup_flags

    listbox $window_name.lb -listvariable setup_flags(detail_list) -width 30 -yscrollcommand [list $window_name.sb set] -selectmode extended -bg lightyellow
    scrollbar $window_name.sb -command [list $window_name.lb yview]
    set f [frame $window_name.f]
    set all [button $f.all -text All -command [list $window_name.lb selection set 0 end]]
    set none [button $f.none -text None -command [list $window_name.lb selection clear 0 end]]
    set delete [button $f.close -text "Close selected" -command [list DetailClear $window_name.lb]]
    pack $all -side left
    pack $none -side left
    pack $delete -side right
    pack $f -side bottom -fill x
    pack $window_name.sb -side right -fill y
    pack $window_name.lb -side left -fill both -expand true
}

proc DetailClear { list_box } {
    foreach i [$list_box curselection] {
    lappend windows [$list_box get $i]
    }
    foreach w $windows {
    DetailDelete $w
    }
}

proc DetailDelete { window_name } {
    global setup_flags
    set i [lsearch -exact $setup_flags(detail_list) $window_name]
    if { $i >= 0 } {
	set setup_flags(detail_list) [lreplace $setup_flags(detail_list) $i $i]
    }
    destroy $window_name
}

# Client list
proc AddClient { client } {
    global ClientList
    if { [info exist ClientList($client)] } {
        incr ClientList($client)
    } else {
        set ClientList($client) 1
    }

    global setup_flags

    if { [ info exist setup_flags(.clientlist) ] } {
        BuildClientList
    }
}

proc BuildClientList { } {
    global stats
    global ClientList
    set l {}
    foreach {k v} [array get ClientList] {
        lappend l [format {%20.20s %8d} $k $v]
    }
    set stats(clientlist) $l
}

# Show a table of Past status messages
proc StatByClient { } {
    set window_name .clientlist
    set menu_name .main_menu.view
    set menu_index "Clients"

    if { [ WindowAlreadyExists $window_name $menu_name $menu_index ] } {
        return
    }

    global stats

    BuildClientList
    listbox $window_name.lb -listvariable stats(clientlist) -width 30 -yscrollcommand [list $window_name.sb set] -bg lightyellow
    scrollbar $window_name.sb -command [list $window_name.lb yview]
    pack $window_name.sb -side right -fill y
    pack $window_name.lb -side left -fill both -expand true
}

# Show a table of Past status messages
proc LengthPersist { } {
    set window_name .lengthpersistwindow
    set menu_name .main_menu.view
    set menu_index "Persistence lengths"

    if { [ WindowAlreadyExists $window_name $menu_name $menu_index ] } {
        return
    }

    global stats

    label $window_name.at -text "Length" -bg blue -fg white
    grid  $window_name.at -row 0 -column 0 -sticky news
    label $window_name.bt -text "Count" -bg blue -fg white
    grid  $window_name.bt -row 0 -column 1 -sticky news

    label $window_name.ax -textvariable stats(persistence_length.max) -bg lightyellow
    grid  $window_name.ax -row 1 -column 0 -sticky news
    label $window_name.bx -text "Max" -bg lightyellow
    grid  $window_name.bx -row 1 -column 1 -sticky news
    label $window_name.am -textvariable stats(persistence_length.mean) -bg lightyellow
    grid  $window_name.am -row 2 -column 0 -sticky news
    label $window_name.bm -text "Mean" -bg lightyellow
    grid  $window_name.bm -row 2 -column 1 -sticky news

    set row 3
    set bg white
    for {set x 0} {$x < 16} {incr x} {
    label $window_name.a${x} -text $x -bg $bg
    grid  $window_name.a${x} -row $row -column 0 -sticky news
    label $window_name.b${x} -textvariable stats(persistence_length.$x) -bg $bg
    grid  $window_name.b${x} -row $row -column 1 -sticky news
    if {$bg=="white"} { set bg lightyellow} else {set bg white}
        incr row
    }
    label $window_name.ap -text "> 15" -bg $bg
    grid  $window_name.ap -row $row -column 0 -sticky news
    label $window_name.bp -textvariable stats(persistence_length.15plus) -bg $bg
    grid  $window_name.bp -row $row -column 1 -sticky news
}

# Show a table of Past status messages
proc RatePersist { } {
    set window_name .ratepersistwindow
    set menu_name .main_menu.view
    set menu_index "Persistence rates"

    if { [ WindowAlreadyExists $window_name $menu_name $menu_index ] } {
        return
    }

    global stats

    label $window_name.a0 -text "Persistence" -bg blue -fg white
    grid  $window_name.a0 -row 0 -column 0 -sticky news
    label $window_name.a1 -text "Requests" -bg lightblue
    grid  $window_name.a1 -row 1 -column 0 -sticky news
    label $window_name.a2 -text "Granted" -bg lightblue
    grid  $window_name.a2 -row 2 -column 0 -sticky news

    label $window_name.b0 -text "number" -bg yellow
    grid  $window_name.b0 -row 0 -column 1 -sticky news
    label $window_name.b1 -textvariable stats(persistence_length.request_yes) -bg white
    grid  $window_name.b1 -row 1 -column 1 -sticky news
    label $window_name.b2 -textvariable stats(persistence_length.grant) -bg white
    grid  $window_name.b2 -row 2 -column 1 -sticky news

    label $window_name.c0 -text "total" -bg orange
    grid  $window_name.c0 -row 0 -column 2 -sticky news
    label $window_name.c1 -textvariable stats(Total.tries) -bg lightyellow
    grid  $window_name.c1 -row 1 -column 2 -sticky news
    label $window_name.c2 -textvariable stats(persistence_length.request_yes) -bg lightyellow
    grid  $window_name.c2 -row 2 -column 2 -sticky news

    label $window_name.d0 -text "rate %" -bg yellow
    grid  $window_name.d0 -row 0 -column 3 -sticky news
    label $window_name.d1 -textvariable stats(persistence_length.request_rate) -bg white
    grid  $window_name.d1 -row 1 -column 3 -sticky news
    label $window_name.d2 -textvariable stats(persistence_length.grant_rate) -bg white
    grid  $window_name.d2 -row 2 -column 3 -sticky news
}

# Show a table of Past status messages
proc StatusWindow { } {
    set window_name .statuswindow
    set menu_name .main_menu.view
    set menu_index "Status messages"

    if { [ WindowAlreadyExists $window_name $menu_name $menu_index ] } {
        return
    }

    global status_messages

    # create status window
    scrollbar $window_name.xsb -orient horizontal -command [list $window_name.lb xview]
    pack $window_name.xsb -side bottom -fill x -expand 1
    scrollbar $window_name.ysb -orient vertical -command [list $window_name.lb yview]
    pack $window_name.ysb -fill y -expand 1 -side right
    listbox $window_name.lb -listvar status_messages -bg white -yscrollcommand [list $window_name.ysb set] -xscrollcommand [list $window_name.xsb set] -width 80
    pack $window_name.lb -fill both -expand 1 -side left
}

#proc window handler for statistics and status windows
#return 1 if old, 0 if new
proc WindowAlreadyExists { window_name menu_name menu_index } {
    global setup_flags

    if { [ info exist setup_flags($window_name) ] } {
	if { $setup_flags($window_name) } {
	    # hide window
	    wm withdraw $window_name
	    set setup_flags($window_name) 0
	} else {
	    # show window
	    wm deiconify $window_name
	    set setup_flags($window_name) 1
	}
	return 1
    }

    # create window
    toplevel $window_name
    wm title $window_name $menu_index
    # delete handler
    wm protocol $window_name WM_DELETE_WINDOW [list $menu_name invoke $menu_index]
    # now set flag
    set setup_flags($window_name) 1
    return 0
}

# Show a table of packets and bytes by type (DIR, READ,...)
# Separate window that is pretty self contained.
# Data values use -textvariable so auto-update
# linked by "globals" for variables and types
# linked my menu position and index (checkbox)
# catches delete and hides instead (via menu action)
proc StatByType { } {
    set window_name .statbytype
    set menu_name .main_menu.view
    set menu_index "Statistics by Message type"

    if { [ WindowAlreadyExists $window_name $menu_name $menu_index ] } {
        return
    }

    global stats
    global MessageListPlus

    # create stats window
    set column_number 0
    label $window_name.l${column_number}0 -text "Type" -bg blue -fg white
    grid $window_name.l${column_number}0 -row 0 -column $column_number -sticky news
    label $window_name.l${column_number}1 -text "Packets" -bg lightblue
    grid $window_name.l${column_number}1 -row 1 -column $column_number -sticky news
    label $window_name.l${column_number}2 -text "Errors" -bg  lightblue
    grid $window_name.l${column_number}2 -row 2 -column $column_number -sticky news
    label $window_name.l${column_number}3 -text "Error %" -bg  lightblue
    grid $window_name.l${column_number}3 -row 3 -column $column_number -sticky news
    frame $window_name.ff4 -bg blue
    grid $window_name.ff4 -column 1 -row 0
    label $window_name.l${column_number}5 -text "bytes in" -bg  lightblue
    grid $window_name.l${column_number}5 -row 5 -column $column_number -sticky news
    label $window_name.l${column_number}6 -text "bytes out" -bg  lightblue
    grid $window_name.l${column_number}6 -row 6 -column $column_number -sticky news
    set bgcolor white
    set bgcolor2 yellow
    foreach x $MessageListPlus {
	incr column_number
	label $window_name.${column_number}0 -text $x -bg $bgcolor2
	grid  $window_name.${column_number}0 -row 0 -column $column_number -sticky news
	label $window_name.${column_number}1 -textvariable stats($x.tries) -bg $bgcolor
	grid  $window_name.${column_number}1 -row 1 -column $column_number -sticky news
	label $window_name.${column_number}2 -textvariable stats($x.errors) -bg $bgcolor
	grid  $window_name.${column_number}2 -row 2 -column $column_number -sticky news
	label $window_name.${column_number}3 -textvariable stats($x.rate) -bg $bgcolor
	grid  $window_name.${column_number}3 -row 3 -column $column_number -sticky news
	label $window_name.${column_number}5 -textvariable stats($x.request_bytes) -bg $bgcolor
	grid  $window_name.${column_number}5 -row 5 -column $column_number -sticky news
	label $window_name.${column_number}6 -textvariable stats($x.response_bytes) -bg $bgcolor
	grid  $window_name.${column_number}6 -row 6 -column $column_number -sticky news
	if { $bgcolor == "white" } {
	    set bgcolor lightyellow
        } else {
	    set bgcolor white
	}
	if { $bgcolor2 == "yellow" } {
	    set bgcolor2 orange
	} else {
	    set bgcolor2 yellow
	}
    }
    frame $window_name.f4 -bg yellow
    grid $window_name.f4 -column 1 -row 4 -columnspan [llength MessageListPlus]
}

#make a window that has to be dismissed by hand
proc TransactionDetail { index } {
    # make a unique window name
    global setup_flags
    set window_name .transaction_$index

    # Does the window exist?
    if { [winfo exists $window_name] == 1 } {
	raise $window_name
	return
    }

    # Make the window
    toplevel $window_name -bg white
    wm title $window_name "Transaction $index"
    set cb_index [cb_from_index $index]

    RequestDetail $window_name $cb_index
    ResponseDetail $window_name $cb_index

    # Add to a list
    set l [concat $setup_flags(detail_list) $window_name]
    set setup_flags(detail_list) [lsort -unique $l]

    # delete handler
    wm protocol $window_name WM_DELETE_WINDOW [list DetailDelete $window_name ]
}

# Parse for TYPE after HeaderParser
proc TypeParser { array_name prefix } {
    upvar 1 $array_name a_name
    global MessageList
    # 268 is 244 sidetap header and 24 owserver header
    if { $a_name($prefix.totallength) < 268 } {
	set a_name($prefix.typetext) BadHeader
	return
    }
    set type [lindex $MessageList $a_name($prefix.type)]
    if { $type == {} } {
	set a_name($prefix.typetext) Unknown
	return
    }
    set a_name($prefix.typetext) $type
}

#Parse header information and place in array
# works for request or response (though type is "ret" in response)
proc HeaderParser { array_name prefix string_value } {
    upvar 1 $array_name a_name
    set length [string length $string_value]
    foreach x {tapversion taphost tappeer version payload type flags size offset typetext taptype} {
	set a_name($prefix.$x) ""
    }
    foreach x {paylength tokenlength totallength ping} {
	set a_name($prefix.$x) 0
    }
    binary scan $string_value {Ia120a120IIIIII} a_name($prefix.tapversion) a_name($prefix.taphost) a_name($prefix.tappeer) a_name($prefix.version) a_name($prefix.payload) a_name($prefix.type) a_name($prefix.flags) a_name($prefix.size) a_name($prefix.offset)
    set a_name($prefix.return) [DetailReturn a_name $prefix]
    # 268 is 244 sidetap header and 24 owserver header
    if { $length < 268 } {
	set a_name($prefix.totallength) $length
	set a_name($prefix.typetext) BadHeader
	return
    }
    if { $a_name($prefix.payload) == -1 } {
	set a_name($prefix.paylength) 0
	set a_name($prefix.ping) 1
    } else {
	set a_name($prefix.paylength) $a_name($prefix.payload)
    }
    if { [expr { $a_name($prefix.tapversion) & 0x10000 } ] == 0x10000 } {
	set a_name($prefix.taptype) "server"
    } else {
	set a_name($prefix.taptype) "client"
    }
    set version $a_name($prefix.version)
    set flags $a_name($prefix.flags)
    set tok [expr { $version & 0xFFFF}]
    set ver [expr { $version >> 16}]
    set a_name($prefix.persist) [expr {($flags&0x04)?1:0}]
    set a_name($prefix.versiontext) "T$tok V$ver"
    set a_name($prefix.flagtext) [DetailFlags $flags]
    set a_name($prefix.tokenlength) [expr {$tok * 16} ]
    # 268 is 244 sidetap header and 24 owserver header
    set a_name($prefix.totallength) [expr {$a_name($prefix.tokenlength)+$a_name($prefix.paylength)+268}]
}

# Request portion
proc RequestDetail { window_name cb_index } {
    global circ_buffer

    DetailRow $window_name yellow orange version payload type flags size offset

    # get request data
    HeaderParser q x $circ_buffer($cb_index.request)
    # request headers
    DetailRow $window_name white lightyellow $q(x.version) $q(x.payload) $q(x.type) $q(x.flags) $q(x.size) $q(x.offset)
    # request headers
    # 268 is 244 sidetap header and 24 owserver header
    if { [string length $circ_buffer($cb_index.request)] >= 268 } {
	TypeParser q x
	DetailRow $window_name white lightyellow $q(x.versiontext) $q(x.paylength) $q(x.typetext) $q(x.flagtext) $q(x.size) $q(x.offset)
	if { $q(x.paylength) > 0 } {
	    switch $q(x.typetext) {
		"WRITE" { DetailPayloadPlus $window_name lightyellow white $circ_buffer($cb_index.request) $q(x.paylength) $q(x.size) }
		default { DetailPayload $window_name lightyellow $circ_buffer($cb_index.request) $q(x.paylength) }
	    }
	}
	wm title $window_name "[wm title $window_name]: $q(x.typetext)"
    }
}

# Response portion
proc ResponseDetail { window_name cb_index } {
    global circ_buffer

    DetailRow $window_name #a6dcff #a6b1ff version payload return flags size offset

    # get response data
    set num $circ_buffer($cb_index.num)
    for {set i 0} {$i < $num} {incr i} {
	HeaderParser r x $circ_buffer($cb_index.response.$i)
	set offset $r(x.offset)
	DetailRowPlus $window_name white #EEEEFF $i $r(x.version) $r(x.payload) $r(x.type) $r(x.flags) $r(x.size) $offset
        # 268 is 244 sidetap header and 24 owserv
		"DIRALL" {set offset [DetailOffset $offset]}
	    }
	    DetailRow $window_name white #EEEEFF $r(x.veer header
	if { [string length $circ_buffer($cb_index.response.$i)] >= 268 } {
	    switch [$window_name.x22 cget -text] {
		"DIR"   -rsiontext) [expr {$r(x.ping)?"PING":$r(x.paylength)}] $r(x.return) $r(x.flagtext) $r(x.size) $offset
	    DetailPayload $window_name #EEEEFF $circ_buffer($cb_index.response.$i) $r(x.paylength)
	}
    }
}

proc DetailPayload { window_name color full_string payload } {
    # 268 is 244 sidetap header and 24 owserver header
    DetailText $window_name $color [string range $full_string 268 [expr {$payload + 268}] ]
}

proc DetailPayloadPlus { window_name color1 color2 full_string payload size } {
    set endpay [expr {268+$payload-$size-1}]
    DetailText $window_name $color1 [string range $full_string 268 $endpay ]
    incr endpay
    DetailText $window_name $color2 [string range $full_string $endpay [expr {$payload + 268}] ]
}

proc DetailText { window_name color text_string } {
    set row [lindex [grid size $window_name] 1]
    set columns [lindex [grid size $window_name] 0]
    label $window_name.t${row} -text $text_string -bg $color -relief ridge -wraplength 640 -justify left -anchor w
    grid  $window_name.t${row} -row $row -columnspan $columns -sticky news
}

# Standard detail row, one cell per value
proc DetailRow { window_name color1 color2 v0 v1 v2 v3 v4 v5 } {
    set row [lindex [grid size $window_name] 1]
    set w0 [label $window_name.x${row}0 -text $v0 -bg $color1]
    DetailRowRest $window_name $color1 $color2 $row $w0 $v1 $v2 $v3 $v4 $v5
}

# Augmented detail row, one cell per value, plus num in blue
proc DetailRowPlus { window_name color1 color2 num v0 v1 v2 v3 v4 v5 } {
    set row [lindex [grid size $window_name] 1]
    set w0 [frame $window_name.x${row}0 -bd 0 -relief flat]
    set n0 [label $w0.n -text $num -bg #a6b1ff -fg white]
    set m0 [label $w0.m -text $v0 -bg $color1]
    pack $n0 -side left -anchor w -fill none
    pack $m0 -side right -fill x -expand 1
    DetailRowRest $window_name $color1 $color2 $row $w0 $v1 $v2 $v3 $v4 $v5
}

# first element could be augmented by packet number
# adds row and widget for first cell instead of value
proc DetailRowRest { window_name color1 color2 row w0 v1 v2 v3 v4 v5 } {
    label $window_name.x${row}1 -text $v1 -bg $color2
    label $window_name.x${row}2 -text $v2 -bg $color1
    label $window_name.x${row}3 -text $v3 -bg $color2
    label $window_name.x${row}4 -text $v4 -bg $color1
    label $window_name.x${row}5 -text $v5 -bg $color2
    grid  $w0 $window_name.x${row}1 $window_name.x${row}2 $window_name.x${row}3 $window_name.x${row}4 $window_name.x${row}5 -row $row -sticky news
}

proc DetailReturn { array_name prefix } {
    upvar 1 $array_name a_name
    if { [info exists a_name($prefix.type)] } {
        set ret $a_name($prefix.type)
    } else {
        return "ESHORT"
    }
    if { $ret >= 0 } {
	return "OK"
    }
    switch -- $ret {
	-1      { return "EPERM"}
	-2      { return "ENOENT"}
	-5      { return "EIO"}
	-12     { return "ENOMEM"}
	-14     { return "EFAULT"}
	-19     { return "ENODEV"}
	-20     { return "ENOTDIR"}
	-21     { return "EISDIR"}
	-22     { return "EINVAL"}
	-34     { return "ERANGE"}
	-42     { return "ENOMSG"}
	default { return "ERROR"}
    }
}

proc DetailOffset { offset } {
    return [expr {$offset&0x0001?"resume ":""}][expr {$offset&0x0002?"alarm ":""}][expr {$offset&0x0004?"ovdr ":""}][expr {$offset&0x8000?"temp ":""}][expr {$offset&0x4000?"volt ":""}][expr {$offset&0x2000?"chain ":""}]
}

proc DetailFlags { flags } {
    switch [expr {($flags >>16)&0xFF}] {
	0 {set T "C"}
	1 {set T "F"}
	2 {set T "K"}
	3 {set T "R"}
	default {set T "?temp"}
    }
    switch [expr {$flags >>24}] {
	0 {set F " f.i"}
	1 {set F " fi"}
	2 {set F " f.i.c"}
	3 {set F " f.ic"}
	4 {set F " fi.c"}
	5 {set F " fic"}
	default {set F " ?format"}
    }
    return $T$F[expr {$flags&0x04?" persist":""}][expr {$flags&0x02?" bus":""}][expr {$flags&0x01?" cache":""}]
}

proc WebResponse { sock } {
    set R [lindex {$Revision: 1.2 $} 1]
    fconfigure $sock -buffering full -translation crlf -blocking 0
    puts $sock "HTTP/1.0 400 Bad Request"
    puts $sock "Date: [clock format [clock seconds] -gmt 1]"
    puts $sock "Server: OWSIDE-$R"
    puts $sock "Last-Modified: [clock format [clock seconds] -gmt 1]"
    puts $sock "Content-Type: text/html"
    puts $sock ""
    puts $sock "<HTML><HEAD><TITLE>OWSIDE-$R owserver protocol inspector</TITLE></HEAD>"
    puts $sock "<BODY><P>Attempt to access OWSIDE directly. You probably meant to access OWHTTPD, the 1-wire web server.</P>"
    puts $sock "<P>For more information see <A HREF=http://www.owfs.org>OWFS website</A> or the <A HREF=http://sourceforge.net/projects/owfs/>Sourceforge site.</A?</P?</BODY></HTML>"
    flush $sock
}

# socket name in readable format
proc PrettySock { sock } {
    set socklist [fconfigure $sock -sockname]
    return [lindex $socklist 1]:[lindex $socklist 2]
}
proc PrettyPeer { sock } {
    set socklist [fconfigure $sock -peername]
    return [lindex $socklist 1]:[lindex $socklist 2]
}

proc MainTitle { tap } {
    wm title . "OWSIDE Sidetap on ($tap)"
}

proc Restart { } {
    foreach channel [file channels] {
        if { [regexp -- {^std(out|in|err)$} $channel ] == 0 } {
	    # change to non-blocking and close
	    if { [ catch {
		fconfigure $channel -blocking 0 ;
		close $channel;
	    } reason ] == 1 } {
		StatusMessage "Error closing channel $channel $reason" 1
	    }
	}
    }
    #    exec [info nameofexecutable] $::argv0 "--" {*}$::argv &
    if { [info nameofexecutable] eq $::argv0 } {
        eval exec [list [info nameofexecutable]] "--" $::argv &
    } else {
        eval exec [list [info nameofexecutable]] [list $::argv0] "--" $::argv "&"
    }
    exit
}

#Finally, all the Proc-s have been defined, so run everything.
Main $argv
