Tcl Source Code

Artifact 2e3d096bce0f162c1f1ef57876dd8db13d5d2b74:

Attachment "fake_http_server.tcl" to ticket [3056775fff] added by twylite 2010-08-31 22:14:36.

---

# Fake HTTP server that returns "Pong!" 

set port 80
set opts {closeAfterSend true}
set tracing false


# ----- Tracing support --------------------------------------------------------

proc Trace {msg} {}
if { $tracing } {
  proc Trace {msg} {
    puts [uplevel 1 [list subst -nocommands $msg]]
  }
}


# ----- Error handling ---------------------------------------------------------

proc bgerror {args} {
  puts "BGERROR $args"
}


# ----- Fake HTTP networking ---------------------------------------------------


proc closechan {opts chan} {
  Trace {[$chan] Closing}
  fileevent $chan readable {}
  fileevent $chan writable {}
  array unset ::BUFFERS $chan
  close $chan
}


proc outbound {opts chan} {

  Trace {[$chan] Sending response}

#for {set i 0} {$i < 10000} {incr i} { incr ::g } ; #FIXME

  puts -nonewline $chan [join [list \
    "HTTP/1.1 200 OK" \
    "Date: [clock format [clock seconds] -format "%a, %e %b %Y %T %Z"]" \
    "Server: WSHOST" \
    "accept-ranges: bytes" \
    "content-length: 5" \
    "content-type: text/plain; charset=utf-8" \
    "vary: Accept-Encoding" \
    "" \
    "Pong!" \
  ] "\r\n"]

  fileevent $chan writable {}
  flush $chan
  
  if { [dict exists $opts closeAfterSend] && [dict get $opts closeAfterSend] } {
    close $chan
  }
}


proc inbound {opts chan} {
  upvar ::BUFFERS($chan) buffer

  if { [eof $chan] } {
    Trace {[$chan] EOF}
    closechan $opts $chan
    return {}
  }

  set data [read $chan]
  append buffer $data
  Trace {[$chan] Received [string length $data] bytes}
  
  if { [string first "\r\n\r\n" $buffer] >= 0 } {
    # Should have HTTP headers
    Trace {[$chan] End of headers}
    fileevent $chan writable [list outbound $opts $chan]
    set buffer {}    
  }
  
}


proc accept {opts clientChan clientAddr clientPort} {
  Trace {[$clientChan] Connect from $clientAddr:$clientPort}
  dict set opts -clientaddr $clientAddr
  dict set opts -clientport $clientPort

  set ::BUFFERS($clientChan) {}
  fconfigure $clientChan -blocking false -translation binary \
    -buffering full -buffersize 16384 
  fileevent $clientChan readable [list inbound $opts $clientChan]
}


# ----- Main app ---------------------------------------------------------------


socket -server [list accept $opts] $port
if { ! $tcl_interactive } { vwait forever }