# tnftp-servers.tcl -- a loopback HTTP origin AND a loopback FTP origin AND the
# tnftp runs against both, in ONE process, for tests/88-tnftp.test. Prints
# tagged `T-<key> <value>` lines the .test asserts on.
#
# One process, for the reason data/wget-httpd.tcl gives at length: this target
# has no working relative timer, so a shell that backgrounds a server and then
# starts a client cannot wait for the listening socket. Binding first and
# driving every client from inside the event loop makes the ordering structural
# rather than timed. Every URL is a dotted quad, so nothing here traverses
# getaddrinfo's dns leg.
#
# WHY AN FTP SERVER IS WRITTEN HERE WHEN THE IMAGE HAS THREE. The ticket names
# vsftpd for its ftp leg and vsftpd is not on this image, so there is no
# named server to drive; proftpd, pure-ftpd and inetutils-ftpd are, and each is
# already covered end to end by its own suite (89-proftpd, 89-pure-ftpd,
# 88-inetutils-net) -- re-driving one here would re-test the SERVER, which is not
# what this ticket ports. What is wanted is the CLIENT against a wire, and this
# stub gives that plus the part a real server cannot: it can answer whatever it
# likes, and it transcribes what it was asked. Two cases below depend on exactly
# that, and neither is reachable through any real ftpd on the image:
#
#   - /bignum declares `Content-Length: 4294967300`, which is the ONE observable
#     that separates a tnftp built with the %lld cross answer from one without.
#     Without it tnftp.h defines NO_LONG_LONG, STRTOLL() degrades to strtol(),
#     and on this 32-bit-long arm the header saturates at LONG_MAX. See the
#     recipes-support/tnftp bbappend.
#   - the FTP control channel is TRANSCRIBED, so the .test can assert which
#     commands the client actually issued (EPSV before PASV, TYPE I, SIZE, REST)
#     rather than inferring them from a file that arrived.

set FIXTURE ""
for {set n 1} {$n <= 140} {incr n} {
    append FIXTURE [format "%04d the quick brown fox jumps over the lazy dog 0123456789\n" $n]
}
set FIXLEN [string length $FIXTURE]

set HTTP_SERVED 0
set UA ""
set RANGE_REQ ""
set FTPLOG {}

proc emit {key value} { puts "T-$key $value" }
proc oneline {s} { string map [list \r " " \n " "] [string trim $s] }

# --- HTTP origin --------------------------------------------------------------
proc http_accept {ch addr port} {
    global FIXTURE FIXLEN HTTP_SERVED UA RANGE_REQ
    incr HTTP_SERVED
    fconfigure $ch -translation crlf -blocking 1
    if {[gets $ch req] < 0} { close $ch; return }
    set range ""
    while {[gets $ch h] >= 0 && $h ne ""} {
        if {[string match -nocase "user-agent:*" $h]} {
            set UA [string trim [string range $h 11 end]]
        }
        if {[string match -nocase "range:*" $h]} {
            set range [string trim [string range $h 6 end]]
            set RANGE_REQ $range
        }
    }
    lassign [split [string trim $req] " "] meth path
    fconfigure $ch -translation binary
    switch -glob -- $path {
        /fixture {
            if {$range ne "" && [regexp {bytes=(\d+)-} $range -> from]} {
                set body [string range $FIXTURE $from end]
                set last [expr {$FIXLEN - 1}]
                puts -nonewline $ch "HTTP/1.0 206 Partial Content\r\nContent-Type: text/plain\r\nContent-Length: [string length $body]\r\nContent-Range: bytes $from-$last/$FIXLEN\r\n\r\n"
                if {$meth ne "HEAD"} { puts -nonewline $ch $body }
            } else {
                puts -nonewline $ch "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: $FIXLEN\r\n\r\n"
                if {$meth ne "HEAD"} { puts -nonewline $ch $FIXTURE }
            }
        }
        /bignum {
            # A length no 32-bit long can hold. The body is deliberately short:
            # the assertion is the header tnftp PARSED, printed by its own -d
            # debug line, and the truncated transfer that follows is expected.
            puts -nonewline $ch "HTTP/1.0 200 OK\r\nContent-Type: application/octet-stream\r\nContent-Length: 4294967300\r\n\r\n"
            if {$meth ne "HEAD"} { puts -nonewline $ch "short\n" }
        }
        default {
            puts -nonewline $ch "HTTP/1.0 404 Not Found\r\nContent-Type: text/plain\r\nContent-Length: 14\r\n\r\n"
            if {$meth ne "HEAD"} { puts -nonewline $ch "no such object" }
        }
    }
    flush $ch
    close $ch
}

# --- FTP origin ---------------------------------------------------------------
# RFC 959 minus everything this exercise does not reach: one user, one directory,
# passive and active data connections, RETR/STOR/SIZE/REST. Each control line the
# client sends is appended to FTPLOG.
set FTP_USER ""
set FTP_REST 0
set FTP_PASV_SRV ""
set FTP_PASV_CH ""
set FTP_PORT_ADDR ""
set FTP_STORED ""

proc ftp_reply {ch text} {
    puts -nonewline $ch "$text\r\n"
    flush $ch
}

proc ftp_pasv_accept {ch addr port} {
    global FTP_PASV_CH
    set FTP_PASV_CH $ch
    fconfigure $ch -translation binary -blocking 1
}

# Open the data connection this transfer should use: the socket a PASV/EPSV
# client already connected to, else an active connect back to the PORT address.
proc ftp_data {} {
    global FTP_PASV_CH FTP_PORT_ADDR
    if {$FTP_PASV_CH ne ""} {
        set d $FTP_PASV_CH
        set FTP_PASV_CH ""
        return $d
    }
    if {$FTP_PORT_ADDR ne ""} {
        lassign $FTP_PORT_ADDR host port
        set FTP_PORT_ADDR ""
        if {[catch {set d [socket $host $port]}]} { return "" }
        fconfigure $d -translation binary -blocking 1
        return $d
    }
    return ""
}

proc ftp_close_pasv {} {
    global FTP_PASV_SRV
    if {$FTP_PASV_SRV ne ""} { catch {close $FTP_PASV_SRV}; set FTP_PASV_SRV "" }
}

proc ftp_accept {ch addr port} {
    global FIXTURE FIXLEN FTPLOG FTP_USER FTP_REST FTP_PASV_SRV FTP_STORED
    fconfigure $ch -translation crlf -blocking 1
    ftp_reply $ch "220 brintos-tnftp-stub FTP server ready"
    while {[gets $ch line] >= 0} {
        set line [string trim $line]
        if {$line eq ""} continue
        lappend FTPLOG [lindex [split $line " "] 0]
        set verb [string toupper [lindex [split $line " "] 0]]
        set arg [string trim [string range $line [string length $verb] end]]
        switch -- $verb {
            USER { set FTP_USER $arg; ftp_reply $ch "331 Password required for $arg" }
            PASS { ftp_reply $ch "230 User $FTP_USER logged in" }
            SYST { ftp_reply $ch "215 UNIX Type: L8" }
            FEAT { ftp_reply $ch "211-Features:\r\n SIZE\r\n REST STREAM\r\n211 End" }
            OPTS { ftp_reply $ch "200 OK" }
            TYPE { ftp_reply $ch "200 Type set to $arg" }
            MODE { ftp_reply $ch "200 Mode set to $arg" }
            STRU { ftp_reply $ch "200 Structure set to $arg" }
            PWD  { ftp_reply $ch "257 \"/\" is the current directory" }
            CWD  { ftp_reply $ch "250 CWD command successful" }
            NOOP { ftp_reply $ch "200 NOOP ok" }
            SIZE {
                if {[string match "*fixture*" $arg]} {
                    ftp_reply $ch "213 $FIXLEN"
                } else {
                    ftp_reply $ch "550 $arg: No such file or directory"
                }
            }
            MDTM { ftp_reply $ch "213 20230507120000" }
            REST { set FTP_REST $arg; ftp_reply $ch "350 Restarting at $arg" }
            EPSV {
                # Answered so the client's FIRST choice is exercised; the .test
                # asserts the transcript shows EPSV rather than a PASV fallback.
                ftp_close_pasv
                set FTP_PASV_SRV [socket -server ftp_pasv_accept -myaddr 127.0.0.1 0]
                set p [lindex [fconfigure $FTP_PASV_SRV -sockname] 2]
                ftp_reply $ch "229 Entering Extended Passive Mode (|||$p|)"
            }
            PASV {
                ftp_close_pasv
                set FTP_PASV_SRV [socket -server ftp_pasv_accept -myaddr 127.0.0.1 0]
                set p [lindex [fconfigure $FTP_PASV_SRV -sockname] 2]
                ftp_reply $ch "227 Entering Passive Mode (127,0,0,1,[expr {$p / 256}],[expr {$p % 256}])"
            }
            PORT {
                set f [split $arg ","]
                set ::FTP_PORT_ADDR [list [join [lrange $f 0 3] "."] \
                    [expr {[lindex $f 4] * 256 + [lindex $f 5]}]]
                ftp_reply $ch "200 PORT command successful"
            }
            RETR {
                if {![string match "*fixture*" $arg]} {
                    ftp_reply $ch "550 $arg: No such file or directory"
                    set FTP_REST 0
                    continue
                }
                ftp_reply $ch "150 Opening BINARY mode data connection"
                # The pending PASV connection may not have been accepted yet:
                # the client connects while we are writing the 150.
                set d ""
                for {set i 0} {$i < 200 && $d eq ""} {incr i} {
                    update
                    set d [ftp_data]
                    if {$d eq ""} { after 10 }
                }
                if {$d eq ""} {
                    ftp_reply $ch "425 Can't build data connection"
                } else {
                    puts -nonewline $d [string range $FIXTURE $FTP_REST end]
                    flush $d
                    close $d
                    ftp_reply $ch "226 Transfer complete"
                }
                set FTP_REST 0
            }
            STOR {
                ftp_reply $ch "150 Opening BINARY mode data connection"
                set d ""
                for {set i 0} {$i < 200 && $d eq ""} {incr i} {
                    update
                    set d [ftp_data]
                    if {$d eq ""} { after 10 }
                }
                if {$d eq ""} {
                    ftp_reply $ch "425 Can't build data connection"
                } else {
                    set FTP_STORED [read $d]
                    close $d
                    ftp_reply $ch "226 Transfer complete"
                }
            }
            QUIT { ftp_reply $ch "221 Goodbye"; break }
            default { ftp_reply $ch "500 '$verb': command not understood" }
        }
    }
    ftp_close_pasv
    catch {close $ch}
}

# --- client side: run one tnftp, event-driven so both accepts can still fire ---
proc runcmd {argv} {
    set ::buf ""
    set ::fin 0
    set f [open "|$argv 2>@1" r]
    fconfigure $f -blocking 0
    fileevent $f readable [list drain $f]
    vwait ::fin
    return [list $::rc $::buf]
}

proc drain {f} {
    if {[eof $f]} {
        fconfigure $f -blocking 1
        set rc 0
        if {[catch {close $f}]} {
            if {[lindex $::errorCode 0] eq "CHILDSTATUS"} {
                set rc [lindex $::errorCode 2]
            } else {
                set rc -1
            }
        }
        set ::rc $rc
        set ::fin 1
    } else {
        append ::buf [read $f]
    }
}

# --- bring both servers up before any client exists ---------------------------
if {[catch {set hsrv [socket -server http_accept -myaddr 127.0.0.1 0]} err]} {
    emit listen-error [oneline $err]
    exit 1
}
if {[catch {set fsrv [socket -server ftp_accept -myaddr 127.0.0.1 0]} err]} {
    emit listen-error [oneline $err]
    exit 1
}
set HPORT [lindex [fconfigure $hsrv -sockname] 2]
set FPORT [lindex [fconfigure $fsrv -sockname] 2]
emit http-port $HPORT
emit ftp-port $FPORT
emit fixlen $FIXLEN

# A port with nothing on it, for the connection-refused cases.
set dead [socket -server {apply {{a b c} {}}} -myaddr 127.0.0.1 0]
set DEADPORT [lindex [fconfigure $dead -sockname] 2]
close $dead

set TN [expr {[info exists ::env(BST_TNFTP)] ? $::env(BST_TNFTP) : "tnftp"}]
set H "http://127.0.0.1:$HPORT"
set F "ftp://bstuser:bstpass@127.0.0.1:$FPORT"
set D [expr {[info exists ::env(BST_TNFTP_DIR)] ? $::env(BST_TNFTP_DIR) : "/tmp"}]

# ckey <bytes> -- a content key. Tcl's zlib command is not guaranteed present
# (data/wget-httpd.tcl already guards for a tclsh built without it), and every
# key here is compared only against another key from this same proc, so the
# fallback's weaker function costs nothing.
if {[catch {zlib crc32 "probe"}]} {
    proc ckey {b} {
        set h 5381
        foreach c [split $b ""] {
            set h [expr {(($h * 33) + [scan $c %c]) & 0xffffffff}]
        }
        return [format %08x $h]
    }
} else {
    proc ckey {b} { return [format %08x [zlib crc32 $b]] }
}

proc sha {path} {
    if {![file exists $path]} { return "absent" }
    set f [open $path rb]; set d [read $f]; close $f
    return [string length $d]:[ckey $d]
}
set WANT [list $FIXLEN [ckey $FIXTURE]]
emit fixture-key [join $WANT ":"]

# --- http:// ------------------------------------------------------------------
lassign [runcmd "$TN -V -o $D/http.out $H/fixture"] rc out
emit http-rc $rc
emit http-key [sha $D/http.out]
emit http-msg [oneline $out]

# The origin's own view of the client. tnftp sends no User-Agent unless it is
# building an HTTP request, so this is proof the http path ran, from the far end.
emit http-ua $UA

lassign [runcmd "$TN -V -o $D/miss.out $H/nosuch"] rc out
emit http-404-rc $rc
emit http-404-msg [oneline $out]

# -o - writes the body to stdout instead of a file.
lassign [runcmd "$TN -V -o - $H/fixture"] rc out
emit http-stdout-rc $rc
emit http-stdout-len [string length $out]

# -R resumes: the partial file already on disk decides the Range header, and the
# result must still be the whole fixture byte for byte.
set half [expr {$FIXLEN / 2}]
set fh [open $D/resume.out wb]; puts -nonewline $fh [string range $FIXTURE 0 [expr {$half - 1}]]; close $fh
set RANGE_REQ ""
lassign [runcmd "$TN -V -R -o $D/resume.out $H/fixture"] rc out
emit http-resume-rc $rc
emit http-resume-key [sha $D/resume.out]
emit http-resume-range $RANGE_REQ
emit http-resume-from $half

# The 64-bit header. -d turns on tnftp's own debug trace, which prints the value
# it parsed; that line is the assertion, not the transfer, which is expected to
# fail short.
lassign [runcmd "$TN -V -d -o $D/big.out $H/bignum"] rc out
emit http-bignum-parsed [oneline $out]

lassign [runcmd "$TN -V -o $D/ref.out http://127.0.0.1:$DEADPORT/fixture"] rc out
emit http-refused-rc $rc
emit http-refused-msg [oneline $out]

# --- ftp:// -------------------------------------------------------------------
set FTPLOG {}
lassign [runcmd "$TN -V -o $D/ftp.out $F/fixture"] rc out
emit ftp-rc $rc
emit ftp-key [sha $D/ftp.out]
emit ftp-msg [oneline $out]
emit ftp-user $FTP_USER
emit ftp-verbs [join $FTPLOG " "]

set FTPLOG {}
lassign [runcmd "$TN -V -o $D/ftpmiss.out $F/nosuch"] rc out
emit ftp-404-rc $rc
emit ftp-404-msg [oneline $out]

# -u uploads, which is the only write direction tnftp has; the origin keeps what
# arrived so the comparison is against the bytes the server received.
set FTP_STORED ""
set FTPLOG {}
lassign [runcmd "$TN -V -u $F/uploaded $D/http.out"] rc out
emit ftp-upload-rc $rc
emit ftp-upload-key [string length $FTP_STORED]:[ckey $FTP_STORED]
emit ftp-upload-verbs [join $FTPLOG " "]

lassign [runcmd "$TN -V -o $D/ftpref.out ftp://127.0.0.1:$DEADPORT/fixture"] rc out
emit ftp-refused-rc $rc

emit http-served $HTTP_SERVED
close $hsrv
close $fsrv
puts "ALL-TNFTP-OK"