# lib/server.tcl
#
# --server untunnel code.
#
# Copyright (C) 2003, 2004
# Andy Goth <unununium@openverse.com>
#
# This code is available under the GNU General Public License; see COPYING.

::snit::type tunnel {
    # Tcl channel used to communicate with this tunnel client.
    variable Channel

    # Hostname of the tunnel client.
    variable Host

    # Port number of the socket associated with the tunnel client.
    variable Port

    # If true, the tunnel client has been authenticated.
    variable Authenticated 0

    # If true, the tunnel client is currently sending binary data.  Therefore,
    # input CRLF-to-LF translation is disabled and no commands are expected.
    variable Send_mode 0

    # If true, the tunnel client is currently receiving binary data, so output
    # LF-to-CRLF translation is disabled and the `end' command won't be sent.
    variable Recv_mode 0

    # Number of binary bytes the tunnel client is expected to send.  This is
    # only useful when $Send_mode is set.
    variable Send_size 0

    # ID of the target to which the tunnel is sending binary data.  This only
    # has meaning when $Send_mode is set.
    variable Send_target

    # Version of the tunnel client software, as set with the `version' command
    # during authentication.
    variable Version unspecified

    # Quiet flag for the tunnel (set with the `quiet' command).  If a tunnel
    # requests quiet, in the protocol extra textual information is suppressed.
    # By default, the protocol is verbose.
    variable Quiet 0

    # Login secret supplied by the tunnel with `secret' during authentication.
    # The tunnel is rejected at `auth' if this does not match the server secret.
    variable Secret ""

    # List of ID's of forwarding targets associated with the tunnel.  Targets
    # are created with the `open' command, and targets are removed with `close'
    # or when the client or target host drops the connection.
    variable Targets {}

    # True if the most recent send operation failed with a broken-pipe error.
    # Used to prevent death, destruction, and infinite loops caused by the
    # destructor sending `end' in response to send invoking the destructor.
    variable Broken 0

    # Called after the `remote' server socket accepts a connection.  Useful
    # with the `fileevent' command.
    #
    # tunnel $name $chan $host $port
    #   $name: Name to assign to the tunnel instance (can be %AUTO%).
    #   $chan: Tcl channel to associate with this tunnel client.
    #   $host: Hostname of the tunnel.
    #   $port: Port number of the socket used to communicate with the tunnel.
    constructor {chan host port} {
        global cfg

        set Chan $chan
        set Host $host
        set Port $port

        log 2 "open tunnel $Chan accept $Host:$Port"

        fconfigure $Chan -blocking 0 -buffering line
        fileevent  $Chan readable [mymethod recv]

        $self send $Chan "version $cfg(version)"
    }

    # Called when destroying the tunnel.
    #
    # $name destroy
    #   $name: Name of the tunnel instance.
    destructor {
        # Destroy all forwarding targets used by this tunnel client.
        foreach id $Targets {
            target$id destroy
        }

        # Tell the remote side about the imminent demise of the connection.
        if {!$Broken && !$Recv_bin} {
            $self send "end"
        }

        log 2 "close tunnel $Chan"

        # Close the Tcl socket channel.
        close $Chan

        # TODO: quit program is there are no more tunnels or servers.
    }
}

# Sends text or binary data to the tunnel client.
# 
# $name send ?options? $msg
#   $name  : Name of the tunnel instance.
#   options: -mode text   : Convert LF to CRLF for network transmission.
#            -mode binary : Send data verbatim.
#            -extra $msg2 : If not $Quiet, send $msg2 after $msg.
#   $msg   : Text or data to send.
::snit::method tunnel send {args} {
    # Extract useful data from $args.
    set mode [from args -mode text]
    set msg2 [from args -extra]
    if {[llength $args] == 1} {
        if {$msg2 ne "" && !$Quiet} {
            set msg "[lindex $args 0] $msg2"
        } else {
            set msg [lindex $args 0]
        }
    } else {
        error "wrong # args: should be \"$self send ?options? msg\""
    }

    # Set up translation.
    switch -- $mode {
    text {
        # Automatic mode: translate Unix-style LF to network-style CRLF.
        set trans [fconfigure $Chan -translation]
        lset trans 1 crlf
        fconfigure $Chan -translation $trans
        set lmsg $msg
    } binary {
        # Binary mode: send data verbatim.
        set trans [fconfigure $Chan -translation]
        lset trans 1 binary
        fconfigure $Chan -translation $trans
        set lmsg "\[[string length $msg] bytes]"
    } default {
        # Something else...?
        error "unknown mode: should be \"text\" or \"binary\""
    }}

    log 4 "send tunnel $Chan $lmsg"

    # Send!
    if {[catch {puts $Chan $msg} result]} {
        # Connection closed ("broken pipe").
        set Broken 1
        $self destroy
        error $result
    }
}

# Reads and processes data coming from the tunnel client.
#
# $name recv
#   $name: Name of the tunnel instance.
::snit::method tunnel recv {} {
    if {$Send_bin} {
        # Client is sending binary data to a target host.
        #
        # I expect that this code is executed after $Send_target's channel is
        # certified to be writable, to avoid Tcl buffering data needlessly and
        # boundlessly.  This means that in $Send_bin, recv is called by a
        # wrapper proc

        set data [read $Chan $Send_size]
        if {[eof $Chan]} {
            # Connection is broken.
            $self destroy
        } else {
            # Send data to outgoing socket.
            set size [string length $data]
            log 4 "recv tunnel $chan \[$size bytes]"
            set result [catch {target$Send_target send $data}]

            incr Send_size -$size
            if {$result || $Send_size <= 0} {
                # Transfer is complete.
                set Send_bin    0
                set Send_target ""
                set Send_size   0
                set trans [fconfigure $Chan -translation]
                lset trans 0 auto
                fconfigure $Chan -translation $trans
            }
        }
        return
    } else {
        # Client is sending commands.
        gets $Chan line
        if {[eof $Chan]} {
            # Connection is broken.
            $self destroy
            return
        }
        # Fall through to process $line.
    }

    log 4 "recv tunnel $chan $line"

    # Split the line into "$cmd $parms".
    set delim [string first " " $line]
    if {$delim == -1} {set delim [string length $line]}
    set cmd   [string range $line 0 [expr {$delim - 1}]]
    set parms [string range $line [expr {$delim + 1}] end]

    # Process the command.
    switch -glob -- "$Authenticated $cmd" {
    "0 secret" {
        # Login password.
        set Secret $parms
    } "0 version" {
        # Tunnel client version string.
        set Version $parms
    } "0 auth" {
        # Attempt to log in.
        if {$Secret eq $secret} { ;# TODO: $secret == ???
          # # TODO: make a server ("remote") type to handle this
          # # Only one client allowed.
          # log 2 "close remote $server_chan 0.0.0.0:$server_port"
          # close $server_chan
          # set server_chan ""
          # foreach client $clients(index) {
          #     if {$client ne $chan} {
          #         client_send $client "fatal Someone else got here first"
          #         client_close $client
          #     }
          # }

            # Successful authentication.
            set Authenticated 1
            $self send $Chan "auth" "Successful authentication"
    } else {
        # Get lost, lamer.
        client_send $chan "fatal Bad secret"
        client_close $chan
    }
} "connected open" {
    # Open a new port forward.
    if {![regexp {^([^ ]+) ([^:]+):([^:]+)$} $parms x id host port]} {
        client_send $chan "warning Invalid forwarding specification"
    } elseif {[lsearch -exact $forwards(index) $id] != -1} {
        client_send $chan "error Forward id \"$id\" in use"
    } elseif {[catch {set sock [socket -async $host $port]} result]} {
        client_send $chan "error socket $host $port: [escape $result]"
        client_send $chan "close $id" [quiet " Forward open failed"]
    } else {
        log 4 "open forward $sock,$id async $host:$port"

        set forwards($id,chan)     $sock
        set forwards($id,status)   connecting
        set forwards($id,owner)    $chan
        set forwards($id,host)     $host
        set forwards($id,port)     $port
        set forwards($id,recv_buf) ""
        lappend forwards(index)    $id

        fconfigure $sock -blocking 0 -buffering none -translation binary
        fileevent $sock writable [list forward_connect $id]
    }
} "connected close" {
    # Close an existing port forward.
    if {![regexp {^([^ ]+)$} $parms x id]} {
        client_send $chan "warning Invalid close command"
    } elseif {[lsearch -exact $forwards(index) $id] == -1} {
        client_send $chan "error Forward id \"$id\" doesn't exist"
    } else {
        forward_close $id
    }
} "connected send" {
    # Send data over a port forward.
    if {![regexp {^([^ ]+) (\d+)$} $parms x id size]} {
        client_send $chan "warning Invalid send command"
    } elseif {[lsearch -exact $forwards(index) $id] == -1} {
        client_send $chan "error Forward id \"$id\" doesn't exist"
    } else {
        client_send $chan "send $id" [quiet " Go ahead"]
        set clients($chan,status)    sending
        set clients($chan,send_id)   $id
        set clients($chan,send_chan) $forwards($id,chan)
        set clients($chan,send_size) $size
    }
} "* end" {
    # Connection close command.
    client_close $chan
} "* quiet" {
    # Adjust the quiet flag.
    switch -- $parms {
    0 - 1   {set be_quiet $parms}
    default {client_send $chan "warning Invalid quiet command"}}
} "* tcl" {
    # Raw TCL script.
    if {$allow_tcl} {
        if {[catch\
        {client_send $chan "tcl [escape [eval $parms]]"} result]} {
            client_send $chan "error [escape $result]"
        }
    } else {
        client_send $chan "warning tcl command disabled"
    }
} default {
    # Ignore unknown commands.
    client_send $chan "warning Unknown command: $cmd"
}}

}

# Used to trim excess text from the protocol if $Quiet is set.
method Hush {msg} {
    if {$Quiet} {
        return ""
    } else {
        return $msg
    }
}
}

# Server mode.  This process was created by the remote-mode untunnel.  It's
# responsible for creating a server socket for the original untunnel to connect
# to.  It gives connection insructions to the remote-mode untunnel, which
# passes that information back to the original untunnel.
proc main {} {
    global clients forwards secret server_port server_chan version

    set clients(index)  {}
    set forwards(index) {}

    log 0 "info misc Starting server"
    log 0 "info pid [pid]"

    # This.  Is.  Secret.
    set secret [format %08x [expr {wide(rand() * 0x100000000)}]]
    log 2 "info secret $secret"

    # Create the server socket, and tell the client how to connect.
    if {[catch {set server_chan [socket -server client_accept 0]} result]} {
        set msg "fatal socket -server: [escape $result]"
        puts  $msg
        log 0 $msg
    } else {
        set server_port [lindex [fconfigure $server_chan -sockname] 2]
        # set server_port 3012

        log 2 "open server $server_chan listen 0.0.0.0:$server_port"

        puts "version $version"
        puts "pid [pid]"
        puts "port $server_port"
        puts "secret $secret"
    }
    puts "end"
    close stdout

    # And wait.
    vwait forever
}

# Background error handler.
proc bgerror {msg} {
    global errorInfo
    log 0 "bgerror [escape $errorInfo]"
}

# Humble logger procedure.
proc log {level msg} {
    global log_level clock_fmt
    if {$level <= $log_level} {
        if {$clock_fmt ne ""} {
            set msg "[clock format [clock seconds] -format $clock_fmt]$msg"
        }
        puts stderr $msg
    }
}

# Silencer.
proc quiet {msg} {
    global be_quiet
    if {$be_quiet} {
        return ""
    } else {
        return $msg
    }
}

# Accepts incoming connections from the client.
proc client_accept {chan host port} {
    global clients version

    log 2 "open client $chan accept $host:$port"

    set clients($chan,status)    authenticating
    set clients($chan,version)   ""
    set clients($chan,secret)    ""
    set clients($chan,forwards)  ""
    set clients($chan,send_id)   ""
    set clients($chan,send_chan) ""
    set clients($chan,send_size) ""
    set clients($chan,host)      $host
    set clients($chan,port)      $port
    lappend clients(index)       $chan

    fconfigure $chan -blocking 0 -buffering line
    fileevent $chan readable [list client_recv $chan]

    client_send $chan "version $version"
}

# Closes a client connection.
proc client_close {chan {end 1}} {
    global clients forwards server_chan

    if {$end} {client_send $chan "end"}
    catch {close $chan}

    foreach forward $clients($chan,forwards) {
        forward_close $forward
    }

    log 2 "close client $chan $clients($chan,host):$clients($chan,port)"

    array unset clients $chan,*
    set clients(index) [lremove $clients(index) $chan]

    if {$server_chan eq ""} {
        log 2 "info misc Shutting down server"
        exit
    }
}

# Wrapper for puts with logging capabilities.
proc client_send {chan msg args} {
    foreach elem $args {
        append msg $elem
    }

    log 4 "send client $chan $msg"
    if {[catch {puts $chan $msg}]} {
        if {$msg ne "end"} {client_close $chan 0}
        return 0
    } else {
        return 1
    }
}

# Accepts incoming data from the client.
proc client_recv {chan} {
    global clients forwards server_chan server_port secret be_quiet allow_tcl

    # Is client sending raw binary data?
    if {$clients($chan,status) eq "sending"} {
        # Send in progress.
        fconfigure $chan -translation binary
        set data [read $chan $clients($chan,send_size)]

        if {[eof $chan]} {
            # Connection is broken.
            client_close $chan
        } else {
            # Send data to outgoing socket.
            fconfigure $chan -translation auto
            set result [forward_send $clients($chan,send_id) $data]
            incr clients($chan,send_size) -[string length $data]
            if {!$result || $clients($chan,send_size) <= 0} {
                # Transfer is complete.
                set clients($chan,status)    connected
                set clients($chan,send_id)   ""
                set clients($chan,send_chan) ""
                set clients($chan,send_size) ""
            }
        }
        return
    } else {
        # Read a line.
        gets $chan line
        if {[eof $chan]} {
            # Connection is broken.
            client_close $chan
            return
        }
        # Fall through.
    }

    log 4 "recv client $chan $line"

    # Split the line.
    set delim [string first " " $line]
    if {$delim == -1} {set delim [string length $line]}
    set cmd   [string range $line 0 [expr {$delim - 1}]]
    set parms [string range $line [expr {$delim + 1}] end]

    # Process the command.
    switch -glob -- "$clients($chan,status) $cmd" {
    "authenticating secret" {
        # Login password.
        set clients($chan,secret) $parms
    } "authenticating version" {
        # Client version string.
        set clients($chan,version) $parms
    } "authenticating auth" {
        # Attempt to log in.
        if {$clients($chan,secret) eq $secret} {
            # Only one client allowed.
            log 2 "close server $server_chan 0.0.0.0:$server_port"
            close $server_chan
            set server_chan ""
            foreach client $clients(index) {
                if {$client ne $chan} {
                    client_send $client "fatal Someone else got here first"
                    client_close $client
                }
            }

            # Successful authentication.
            set clients($chan,status) connected
            client_send $chan "auth" [quiet " Successful authentication"]
        } else {
            # Get lost, lamer.
            client_send $chan "fatal Bad secret"
            client_close $chan
        }
    } "connected open" {
        # Open a new port forward.
        if {![regexp {^([^ ]+) ([^:]+):([^:]+)$} $parms x id host port]} {
            client_send $chan "warning Invalid forwarding specification"
        } elseif {[lsearch -exact $forwards(index) $id] != -1} {
            client_send $chan "error Forward id \"$id\" in use"
        } elseif {[catch {set sock [socket -async $host $port]} result]} {
            client_send $chan "error socket $host $port: [escape $result]"
            client_send $chan "close $id" [quiet " Forward open failed"]
        } else {
            log 4 "open forward $sock,$id async $host:$port"

            set forwards($id,chan)     $sock
            set forwards($id,status)   connecting
            set forwards($id,owner)    $chan
            set forwards($id,host)     $host
            set forwards($id,port)     $port
            set forwards($id,recv_buf) ""
            lappend forwards(index)    $id

            fconfigure $sock -blocking 0 -buffering none -translation binary
            fileevent $sock writable [list forward_connect $id]
        }
    } "connected close" {
        # Close an existing port forward.
        if {![regexp {^([^ ]+)$} $parms x id]} {
            client_send $chan "warning Invalid close command"
        } elseif {[lsearch -exact $forwards(index) $id] == -1} {
            client_send $chan "error Forward id \"$id\" doesn't exist"
        } else {
            forward_close $id
        }
    } "connected send" {
        # Send data over a port forward.
        if {![regexp {^([^ ]+) (\d+)$} $parms x id size]} {
            client_send $chan "warning Invalid send command"
        } elseif {[lsearch -exact $forwards(index) $id] == -1} {
            client_send $chan "error Forward id \"$id\" doesn't exist"
        } else {
            client_send $chan "send $id" [quiet " Go ahead"]
            set clients($chan,status)    sending
            set clients($chan,send_id)   $id
            set clients($chan,send_chan) $forwards($id,chan)
            set clients($chan,send_size) $size
        }
    } "* end" {
        # Connection close command.
        client_close $chan
    } "* quiet" {
        # Adjust the quiet flag.
        switch -- $parms {
        0 - 1   {set be_quiet $parms}
        default {client_send $chan "warning Invalid quiet command"}}
    } "* tcl" {
        # Raw TCL script.
        if {$allow_tcl} {
            if {[catch\
            {client_send $chan "tcl [escape [eval $parms]]"} result]} {
                client_send $chan "error [escape $result]"
            }
        } else {
            client_send $chan "warning tcl command disabled"
        }
    } default {
        # Ignore unknown commands.
        client_send $chan "warning Unknown command: $cmd"
    }}
}

# Handles completion of outgoing connections.
proc forward_connect {id} {
    global clients forwards

    set chan  $forwards($id,chan)
    set owner $forwards($id,owner)
    set host  $forwards($id,host)
    set port  $forwards($id,port)

    fileevent $chan writable ""
    set result [fconfigure $chan -error]

    if {$result eq ""} {
        # Success.
        log 4 "open forward $chan,$id connect $host:$port"
        client_send $owner "open $id" [quiet " Forward opened successfully"]
        set forwards($id,status) connected
        fileevent $chan readable [list forward_recv $id]
    } else {
        # Failure.
        forward_close $id $result
    }
}

# Closes an outgoing connection.
proc forward_close {id {msg ""}} {
    global forwards clients

    set chan  $forwards($id,chan)
    set owner $forwards($id,owner)

    switch -- $forwards($id,status) {
    connecting {
        if {$msg eq ""} {
            set msg "Forward open failed"
        } else {
            set msg "Forward open failed: [escape $msg]"
        }
    } connected {
        set msg "Forwarded connection closed"
    } closing {
        set msg "Connection closed by remote host"
    }}

    client_send $owner "close $id" [quiet " $msg"]

    log 4 "close forward $chan,$id $forwards($id,host):$forwards($id,port)"
    close $forwards($id,chan)
    array unset forwards $id,*
    set forwards(index) [lremove $forwards(index) $id]
    set clients($owner,forwards) [lremove $clients($owner,forwards) $id]
}

# Sends raw binary data to a forwarded connection.
proc forward_send {id msg} {
    global forwards

    set chan $forwards($id,chan)
    set size [string length $msg]

    log 4 "send forward $chan,$id \[$size binary bytes]"

    if {[catch {puts -nonewline $chan $msg}]} {
        forward_close $chan 0
        return 0
    } else {
        return 1
    }
}

# Accepts incoming data from the forwarded connection.
proc forward_recv {id} {
    global forwards chunk_size

    set chan  $forwards($id,chan)
    set owner $forwards($id,owner)

    set data [read $chan $chunk_size]

    if {[eof $chan]} {
        # Connection is broken.
        forward_close $id
    } else {
        # Send data to client.
        set size [string length $data]
        log 4 "recv forward $chan,$id \[$size binary bytes]"
        client_send $owner "recv $id $size" [quiet " Incoming data from\
                            $forwards($id,host):$forwards($id,port)"]

        log 4 "send client $chan \[$size binary bytes]"
        fconfigure $owner -translation binary
        if {[catch {puts -nonewline $owner $data}]} {
            client_close $owner 0
            return 0
        } else {
            fconfigure $owner -translation auto
            return 1
        }
    }
}

# vim: set ts=4 sts=4 sw=4 tw=80 et: