Tcl Library Source Code

    my puts "<tr><th>$f</th><td>$v</td></tr>"
  }
  my puts "<tr><th>File Size</th><td>[my request get CONTENT_LENGTH]</td></tr>"
  my puts </TABLE>
  my puts </BODY></HTML>
}

set portlist {}
set info {}
if {[dict exists $serveropts myaddr]} {
  dict set info SERVER_IP [dict get $serveropts myaddr]
}
if {[dict exists $serveropts port]} {
  dict set info SERVER_PORT [dict get $serveropts port]
  lappend portlist $info
} else {
  dict set info SERVER_PORT auto
  lappend portlist $info
}
if {[dict exists $serveropts cafile] && ![catch {package require tls}]} {
  dict set info SERVER_SSL 1
  dict set info CA_FILE [dict get $serveropts cafile]
  if {[dict exists $serveropts port_ssl]} {
    dict set info SERVER_PORT [dict get $serveropts port_ssl]
    lappend portlist $info
  } else {
    dict set info SERVER_PORT auto
    lappend portlist $info
  }
}
puts $portlist
appmain start $portlist

puts [list LISTENING on [appmain port_listening]]
cron::main

  clay set socket/ blocking     0
  clay set socket/ translation  {binary binary}

  method debug args {
    puts $args
  }

  method Connect {uuid sock ip {info {}}} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
        -blocking 1 \
        -translation {binary binary} \
        -buffersize 4096 \
        -buffering none
    my counter url_hit
    try {
      # Read the SCGI request on byte at a time until we reach a ":"
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      dict set query http REQUEST_URI /
      dict set query http REMOTE_ADDR $ip
      foreach {f v} $info {
        dict set query http $f $v
      }
      set size {}
      while 1 {
        set char [::coroutine::util::read $sock 1]
        if {[chan eof $sock]} {
          catch {close $sock}
          return
        }

      set arglist [lindex $args 0]
    } else {
      set arglist $args
    }
    foreach {var val} $arglist {
      my clay set server/ $var $val
    }

  }

  destructor {
    my stop
  }

  ###
  # Reply to an open socket. This method builds a coroutine to manage the remainder
  # of the connection. The coroutine's operations are driven by the [cmd Connect] method.
  ###
  method connect args {
    switch [llength $args] {
      3 {
        set info {}
        lassign $args sock ip port
      }
      4 {
        lassign $args info sock ip port
      }
      default {
        error "Usage: [self method] ?info? sock ip port"
      }
    }
    ###
    # If an IP address is blocked drop the
    # connection
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
      return
    }
    set uuid [my Uuid_Generate]
    set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip $info]]]
    chan event $sock readable $coro
  }

  method ServerHeaders {ip http_request mimetxt} {
    set result {}
    dict set result HTTP_HOST {}
    dict set result CONTENT_LENGTH 0

  # determine if the request is valid, and/or what kind of reply to generate. Under
  # normal cases, an object of class [cmd ::http::reply] is created, and that class's
  # [cmd dispatch] method.
  # This action passes control of the socket to
  # the reply object. The reply object manages the rest of the transaction, including
  # closing the socket.
  ###
  method Connect {uuid sock ip {info {}}} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    my counter url_hit
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 http_request]
      set mimetxt [my HttpHeaders $sock]
      dict set query UUID $uuid
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http [my ServerHeaders $ip $http_request $mimetxt]
      foreach {f v} $info {
        dict set query http $f $v
      }
      my Headers_Process query
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}

  }

  method source {filename} {
    source $filename
  }

  # Open the socket listener.
  method start {{portlist {}}} {
    # Build a namespace to contain replies
    namespace eval [namespace current]::reply {}

    my variable socklist port_listening
    if {[my clay get server/ configuration_file] ne {}} {
      source [my clay get server/ configuration_file]
    }
    if {[llength $portlist]==0} {
      set port [my clay get server/ port]
      if {$port in {{} auto}} {

        set port [::nettool::allocate_port 8015]
      }
      set info {}
      dict set info SERVER_PORT $port
      set myaddr [my clay get server/ myaddr]
      if {$myaddr ni {all any * {}}} {
        dict set info SERVER_IP $myaddr
      }
      lappend portlist $info
    }
    foreach info $portlist {
      if {[dict exists $info SERVER_SSL] && [dict get $info SERVER_SSL]} {
        package require tls
        set cmd ::tls::socket
        set opts {-tls1 1 -ssl2 0 -ssl3 0}
        if {[dict exist $info CA_FILE]} {
	  lappend opts -cafile [dict get $info CA_FILE]
        }
      } else {
        set cmd ::socket
        set opts {}
      }
      if {![dict exists $info SERVER_PORT] || [dict get $info SERVER_PORT] in {{} auto}} {
        package require nettool
        dict set info SERVER_PORT [::nettool::allocate_port 8015]
      }
      if {[dict exists $info SERVER_IP] && [llength [dict get $info SERVER_IP]]} {
        foreach ip [dict get $info SERVER_IP] {
          puts [list $cmd -server [namespace code [list my connect $info]] {*}$opts -myaddr $ip [dict get $info SERVER_PORT]]
          lappend socklist [$cmd -server [namespace code [list my connect $info]] {*}$opts -myaddr $ip [dict get $info SERVER_PORT]]
          lappend port_listening $info
        }
      } else {
        puts [list $cmd -server [namespace code [list my connect $info]] {*}$opts  [dict get $info SERVER_PORT]]
        lappend socklist [$cmd -server [namespace code [list my connect $info]] {*}$opts [dict get $info SERVER_PORT]]
        lappend port_listening $info
      }
    }
    my debug [list [self] listening on $port_listening]

    ::cron::every [self] 120 [namespace code {my CheckTimeout}]
    my Thread_start
  }

  # Shut off the socket listener, and destroy any pending replies.
  method stop {} {
    my variable socklist

[list_begin definitions]
[call method [cmd "constructor"] [arg args] [opt "[arg port] [const "auto"]"] [opt "[arg myaddr] [const "127.0.0.1"]"] [opt "[arg string] [const "auto"]"] [opt "[arg name] [const "auto"]"] [opt "[arg doc_root] [const ""]"] [opt "[arg reverse_dns] [const "0"]"] [opt "[arg configuration_file] [const ""]"] [opt "[arg protocol] [const "HTTP/1.1"]"]]


[call method [cmd "destructor"] [opt "[arg dictargs]"]]


[call method [cmd "connect"] [opt "[arg args]"]]

 Reply to an open socket. This method builds a coroutine to manage the remainder
 of the connection. The coroutine's operations are driven by the [cmd Connect] method.




[call method [cmd "ServerHeaders"] [arg ip] [arg http_request] [arg mimetxt]]


[call method [cmd "Connect"] [arg uuid] [arg sock] [arg ip] [opt "[arg info] [const ""]"]]

 This method reads HTTP headers, and then consults the [cmd dispatch] method to
 determine if the request is valid, and/or what kind of reply to generate. Under
 normal cases, an object of class [cmd ::http::reply] is created, and that class's
 [cmd dispatch] method.
 This action passes control of the socket to
 the reply object. The reply object manages the rest of the transaction, including

 needed for the application.



[call method [cmd "source"] [arg filename]]


[call method [cmd "start"] [opt "[arg portlist] [const ""]"]]
 Open the socket listener.



[call method [cmd "stop"]]
 Shut off the socket listener, and destroy any pending replies.

[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "debug"] [opt "[arg args]"]]


[call method [cmd "Connect"] [arg uuid] [arg sock] [arg ip] [opt "[arg info] [const ""]"]]


[list_end]
[para]

[subsection {Class  httpd::content.websocket}]

      set arglist [lindex $args 0]
    } else {
      set arglist $args
    }
    foreach {var val} $arglist {
      my clay set server/ $var $val
    }

  }
  destructor {
    my stop
  }
  method connect args {
    switch [llength $args] {
      3 {
        set info {}
        lassign $args sock ip port
      }
      4 {
        lassign $args info sock ip port
      }
      default {
        error "Usage: [self method] ?info? sock ip port"
      }
    }
    ###
    # If an IP address is blocked drop the
    # connection
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
      return
    }
    set uuid [my Uuid_Generate]
    set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip $info]]]
    chan event $sock readable $coro
  }
  method ServerHeaders {ip http_request mimetxt} {
    set result {}
    dict set result HTTP_HOST {}
    dict set result CONTENT_LENGTH 0
    foreach {f v} [my MimeParse $mimetxt] {

    dict set result SERVER_PROTOCOL [my clay get server/ protocol]
    dict set result SERVER_SOFTWARE [my clay get server/ string]
    if {[string match 127.* $ip]} {
      dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}]
    }
    return $result
  }
  method Connect {uuid sock ip {info {}}} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    my counter url_hit
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 http_request]
      set mimetxt [my HttpHeaders $sock]
      dict set query UUID $uuid
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http [my ServerHeaders $ip $http_request $mimetxt]
      foreach {f v} $info {
        dict set query http $f $v
      }
      my Headers_Process query
      set reply [my dispatch $query]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}

    set prefix [string trimright $prefix *]
    set prefix [string trimright $prefix /]
    return $prefix
  }
  method source {filename} {
    source $filename
  }
  method start {{portlist {}}} {
    # Build a namespace to contain replies
    namespace eval [namespace current]::reply {}

    my variable socklist port_listening
    if {[my clay get server/ configuration_file] ne {}} {
      source [my clay get server/ configuration_file]
    }
    if {[llength $portlist]==0} {
      set port [my clay get server/ port]
      if {$port in {{} auto}} {

        set port [::nettool::allocate_port 8015]
      }
      set info {}
      dict set info SERVER_PORT $port
      set myaddr [my clay get server/ myaddr]
      if {$myaddr ni {all any * {}}} {
        dict set info SERVER_IP $myaddr
      }
      lappend portlist $info
    }
    foreach info $portlist {
      if {[dict exists $info SERVER_SSL] && [dict get $info SERVER_SSL]} {
        package require tls
        set cmd ::tls::socket
        set opts {-tls1 1 -ssl2 0 -ssl3 0}
        if {[dict exist $info CA_FILE]} {
	  lappend opts -cafile [dict get $info CA_FILE]
        }
      } else {
        set cmd ::socket
        set opts {}
      }
      if {![dict exists $info SERVER_PORT] || [dict get $info SERVER_PORT] in {{} auto}} {
        package require nettool
        dict set info SERVER_PORT [::nettool::allocate_port 8015]
      }
      if {[dict exists $info SERVER_IP] && [llength [dict get $info SERVER_IP]]} {
        foreach ip [dict get $info SERVER_IP] {
          puts [list $cmd -server [namespace code [list my connect $info]] {*}$opts -myaddr $ip [dict get $info SERVER_PORT]]
          lappend socklist [$cmd -server [namespace code [list my connect $info]] {*}$opts -myaddr $ip [dict get $info SERVER_PORT]]
          lappend port_listening $info
        }
      } else {
        puts [list $cmd -server [namespace code [list my connect $info]] {*}$opts  [dict get $info SERVER_PORT]]
        lappend socklist [$cmd -server [namespace code [list my connect $info]] {*}$opts [dict get $info SERVER_PORT]]
        lappend port_listening $info
      }
    }
    my debug [list [self] listening on $port_listening]

    ::cron::every [self] 120 [namespace code {my CheckTimeout}]
    my Thread_start
  }
  method stop {} {
    my variable socklist
    if {[info exists socklist]} {
      foreach sock $socklist {

  superclass ::httpd::server
  clay set socket/ buffersize   32768
  clay set socket/ blocking     0
  clay set socket/ translation  {binary binary}
  method debug args {
    puts $args
  }
  method Connect {uuid sock ip {info {}}} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
        -blocking 1 \
        -translation {binary binary} \
        -buffersize 4096 \
        -buffering none
    my counter url_hit
    try {
      # Read the SCGI request on byte at a time until we reach a ":"
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      dict set query http REQUEST_URI /
      dict set query http REMOTE_ADDR $ip
      foreach {f v} $info {
        dict set query http $f $v
      }
      set size {}
      while 1 {
        set char [::coroutine::util::read $sock 1]
        if {[chan eof $sock]} {
          catch {close $sock}
          return
        }

###
# Build the server
###
set DIR [file dirname [file normalize [info script]]]
set ::DEMOROOT $DIR

::httpd::server create TESTAPP port 10001
TESTAPP start
TESTAPP plugin dict_dispatch
TESTAPP uri add * /     [list mixin {reply ::test::content.echo}]
TESTAPP uri add * /echo [list mixin {reply ::test::content.echo}]
TESTAPP uri add * /file [list mixin {reply ::test::content.file} doc_root $::DEMOROOT]
TESTAPP uri add * /time [list mixin {reply ::test::content.time}]
TESTAPP uri add * /error [list mixin {replyy ::test::content.error}]

	superclass ::httpd::content.proxy

  method proxy_channel {} {
    return [::socket localhost [my clay get proxy_port]]
  }
}


::httpd::server create TESTPROXY port 10002
TESTPROXY start
TESTAPP   uri add * /proxy*     [list mixin {reply ::test::content.proxy} proxy_port 10002]
TESTPROXY plugin dict_dispatch
TESTPROXY uri add * /     [list mixin {reply ::test::content.echo}]
TESTPROXY uri add * /echo [list mixin {reply ::test::content.echo}]
TESTPROXY uri add * /file [list mixin {reply ::test::content.file} doc_root $::DEMOROOT]
TESTPROXY uri add * /time [list mixin {reply ::test::content.time}]
TESTPROXY uri add * /error [list mixin {reply ::test::content.error}]

  superclass ::httpd::server.scgi

  clay set reply_class ::scgi::test::reply
}

puts [list ::test::content.file [info commands ::test::content.file]]
scgi::test::app create TESTSCGI port 10003
TESTSCGI start
TESTSCGI plugin dict_dispatch
TESTSCGI uri add * /     [list mixin {reply ::test::content.echo}]
TESTSCGI uri add * /echo [list mixin {reply ::test::content.echo}]
TESTSCGI uri add * /file [list mixin {reply ::test::content.file} doc_root $::DEMOROOT]
TESTSCGI uri add * /time [list mixin {reply ::test::content.time}]
TESTSCGI uri add * /error [list mixin {reply ::test::content.error}]