minase · February 1, 2013 05:14
diff --git a/phttpsv.tcl b/phttpsv.tcl
 #!/usr/bin/env tclsh

 proc http_server {sock host port} {
  set request  [read_request $sock]
  set response [mk_response]

  # puts to stdout
  puts "==== Request header(from: $host:$port) ===="
  puts $request
  puts "==== Response header and body ===="
  puts $response

  # puts to socket
  puts $sock $response

  close $sock

  return 0
 }

 proc read_request {sock} {
  set request [gets $sock]

  if ![regexp {^GET\s+/\s+HTTP/1\.1$} $request] {
    puts  $sock "invalid request."
    close $sock
    return 1
  }

  while 1 {
    set buffer [gets $sock]

    if [regexp {^$} $buffer] {break}

    lappend request $buffer
  }

  return [join $request "\n"]
 }

 proc mk_response args {
  set contents [mk_contents "phttpsv.tcl" "Welcome to Tcl world!!"]
  set headers  [mk_headers $contents]

  return [join "$headers $contents" "\n"]
 }

 proc mk_headers {contents} {
  set date   [clock format [clock seconds] -format "%a, %d %b %y %T GMT" -gmt true]
  set length [string bytelength $contents]

  lappend headers "HTTP/1.0 200 OK"
  lappend headers "Date: $date"
  lappend headers "Server: Poor HTTP server by Tcl"
  lappend headers "Content-Type: text/html; charset=utf-8"
  lappend headers "Content-Length: $length"
  lappend headers "Connection: close"
  lappend headers ""

  return $headers
 }

 proc mk_contents {title body} {
  lappend contents "<html>"
  lappend contents "  <head>"
  lappend contents "    <title>$title</title>"
  lappend contents "  </head>"
  lappend contents "  <body>"
  lappend contents "    <p>$body</p>"
  lappend contents "  </body>"
  lappend contents "</html>"

  return $contents
 }

 # main
 set myaddr [lindex $argv 0]
 set myport [lindex $argv 1]

 set sock [socket -server http_server -myaddr $myaddr $myport]

 vwait sock
	#!/usr/bin/env tclsh

	proc http_server {sock host port} {
	set request [read_request $sock]
	set response [mk_response]

	# puts to stdout
	puts "==== Request header(from: $host:$port) ===="
	puts $request
	puts "==== Response header and body ===="
	puts $response

	# puts to socket
	puts $sock $response

	close $sock

	return 0
	}

	proc read_request {sock} {
	set request [gets $sock]

	if ![regexp {^GET\s+/\s+HTTP/1\.1$} $request] {
	puts $sock "invalid request."
	close $sock
	return 1
	}

	while 1 {
	set buffer [gets $sock]

	if [regexp {^$} $buffer] {break}

	lappend request $buffer
	}

	return [join $request "\n"]
	}

	proc mk_response args {
	set contents [mk_contents "phttpsv.tcl" "Welcome to Tcl world!!"]
	set headers [mk_headers $contents]

	return [join "$headers $contents" "\n"]
	}

	proc mk_headers {contents} {
	set date [clock format [clock seconds] -format "%a, %d %b %y %T GMT" -gmt true]
	set length [string bytelength $contents]

	lappend headers "HTTP/1.0 200 OK"
	lappend headers "Date: $date"
	lappend headers "Server: Poor HTTP server by Tcl"
	lappend headers "Content-Type: text/html; charset=utf-8"
	lappend headers "Content-Length: $length"
	lappend headers "Connection: close"
	lappend headers ""

	return $headers
	}

	proc mk_contents {title body} {
	lappend contents "<html>"
	lappend contents " <head>"
	lappend contents " <title>$title</title>"
	lappend contents " </head>"
	lappend contents " <body>"
	lappend contents " <p>$body</p>"
	lappend contents " </body>"
	lappend contents "</html>"

	return $contents
	}

	# main
	set myaddr [lindex $argv 0]
	set myport [lindex $argv 1]

	set sock [socket -server http_server -myaddr $myaddr $myport]

	vwait sock