Class ::xo::HttpCore

::xo::HttpCore[i] create ...

Class Relations

  • class: ::xotcl::Class[i]
  • superclass: ::xotcl::Object[i]
  • subclass: ::xo::HttpRequest[i], ::xo::AsyncHttpRequest[i]
::xotcl::Class create ::xo::HttpCore \
     -superclass ::xotcl::Object

Methods (to be applied on instances)

  • GET (scripted)

    :instvar S
puts $S ""
:request_done

  • POST (scripted)

    :instvar S post_data
array set "" [:get_channel_settings [:content_type]]
if {$(encoding) ne "binary"} {
  set post_data [encoding convertto $(encoding) $post_data]
}
puts $S "Content-Length: [string length $post_data]"
puts $S "Content-Type: [:content_type]"
puts $S ""
fconfigure $S -translation $(translation) -encoding binary
:send_POST_data

  • cancel (scripted)

    set :status canceled
set :cancel_message $reason
:debug "--- canceled for $reason"
:close

  • close (scripted)

    catch {close ${:S}} errMsg
:debug "--- closing socket socket?[info exists :S] => $errMsg"

  • content_type (setter)

  • exists_status (scripted)
    

    return [nsv_exists bgdelivery $key]
  • finish (scripted)
    

    set :status finished
:close
:debug "--- [:host] [:port] [:path] has finished"
  • getLine (scripted)
    

    :upvar $var response
:instvar S
set n [gets $S response]
if {[eof $S]} {
  :debug "--premature eof"
  return -2
}
if {$n == -1} {:debug "--input pending, no full line"; return -1}
return $n
  • get_channel_settings (scripted)
    

    #
# 1. NOTE: We have to treat translation and encoding settings
# separately. "Defaulting" to "binary" translation would imply a
# "binary" encoding: [fconfigure -translation binary] "[...] sets
# the encoding to binary (which disables encoding filtering)",
# i.e. it is idempotent to [fconfigure -translation binary
# -encoding binary].
#
# see also http://docs.activestate.com/activetcl/8.5/tcl/TclCmd/fconfigure.htm
#
# 2. Note: I would claim here that we could stick with binary
# translations, effectively deactivating any eol/eof
# interpretations. As we use the byte-oriented [read] rathen than
# the line-oriented [gets] in the processing of HTTP bodies of replies
# ([gets] is only applied for header processing), this should be
# fine. Anyways, I leave it as is for the moment ...
#
set content_type [string tolower $content_type]
set trl [expr {[string match "text/*" $content_type] ? $text_translation : "binary"}]

#
# 3. In the following, an IANA/MIME charset resolution scheme is
# implemented which is compliant with RFC 3023 which deals with
# treating XML media types properly.
#
# see http://tools.ietf.org/html/rfc3023
#
# This makes the use of [ns_encodingfortype] obsolete as this
# helper proc does not consider RFC 3023 at all. In the future,
# RFC 3023 support should enter a revised [ns_encodingfortype],
# for now, we fork.
#
# The mappings between Tcl encoding names (as shown by [encoding
# names]) and IANA/MIME charset names (i.e., names and aliases in
# the sense of http://www.iana.org/assignments/character-sets) is
# provided by ...
#
# i. A static, built-in correspondence map: see nsd/encoding.c
# ii. An extensible correspondence map (i.e., the ns/charsets
# section in config.tcl).
#
# For mapping charset to encoding names, I use
# [ns_encodingforcharset].
#
# Note, there are also alternatives for resolving IANA/MIME
# charset names to Tcl encoding names, however, they all have
# issues (non-extensibility from standard configuration sites,
# incompleteness, redundant thread-local storing, scripted
# implementation):
# 1. Tcllib/mime package: ::mime::reversemapencoding()
# 2. Tdom: tDOM::IANAEncoding2TclEncoding(); see lib/tdom.tcl

#
# RFC 3023 support (at least in my reading) demands the following
# resolution order (see also Section 3.6 in RFC 3023), when
# applied along with RFC 2616 (see especially Section 3.7.1 in RFC 2616)
#
# (A) Check for the "charset" parameter on certain (!) media types:
# an explicitly stated, yet optional "charset" parameter is
# permitted for all text/* media subtypes (RFC 2616) and selected
# the XML media type classes listed by RFC 3023 (beyond the text/*
# media type; e.g. "application/xml*", "*/*+xml", etc.).
#
# (B) If the "charset" is omitted, certain default values apply (!):
#
#    (B.1) RFC 3023 text/* registrations default to us-ascii (!),
#    and not iso-8859-1 (overruling RFC 2616).
#
#   (B.2) RFC 3023 application/* and non-text "+xml" registrations
#    are to be left untreated (in our context, no encoding
#    filtering is to be applied -> "binary")
#
#   (B.3) RFC 2616 text/* registration (if not covered by B.1)
#   default to iso-8859-1
#
# (C) If neither A or B apply (e.g., because an invalid charset
# name was given to the charset parameter), we default to
# "binary". This corresponds to the behavior of
# [ns_encodingfortype].  Also note that the RFCs 3023 and 2616 do
# not state any procedure when "invalid" charsets etc. are
# identified. I assume, RFC-compliant clients have to ignore them
# which means keep the channel in- and output unfiltered (encoding
# = "binary"). This requires the client of the *HttpRequest* to
# treat the data accordingly.
#

set enc ""
if {[regexp {^text/.*$|^.*/xml.*$|^.*\+xml.*$} $content_type]} {
  # Case (A): Check for an explicitly provided charset parameter
  if {[regexp {;\s*charset\s*=([^;]*)} $content_type _ charset]} {
    set enc [ns_encodingforcharset [string trim $charset]]
  }
  # Case (B.1)
  if {$enc eq "" && [regexp {^text/xml.*$|text/.*\+xml.*$} $content_type]} {
    set enc [ns_encodingforcharset us-ascii]
  }

  # Case (B.3)
  if {$enc eq "" && [string match "text/*" $content_type]} {
    set enc [ns_encodingforcharset iso-8859-1]
  }
}

# Cases (C) and (B.2) are covered by the [expr] below.
return [list encoding [expr {$enc eq ""?"binary":$enc}] translation $trl]
  • get_status (scripted)
    

    return [lindex [nsv_get bgdelivery $key] 0]
  • get_value_for_status (scripted)
    

    return [lindex [nsv_get bgdelivery $key] 1]
  • header (scripted)
    

    while {1} {
  set n [:getLine response]
  switch -exact -- $n {
    -2 {:cancel premature-eof; return}
    -1 {continue}
    0 {break}
    default {
      #:debug "--header $response"
      if {[regexp -nocase {^content-length:(.+)$} $response _ length]} {
        set :content_length [string trim $length]
      } elseif {[regexp -nocase {^content-type:(.+)$} $response _ type]} {
        set :content_type [string trim $type]
      }
      if {[regexp -nocase {^([^:]+): *(.+)$} $response _ key value]} {
        lappend :meta [string tolower $key] $value
      }
    }
  }
}
:reply_header_done
  • host (setter)
    

  • init (scripted)
    

    :instvar S post_data host port protocol
:destroy_on_cleanup

set :meta [list]
set :data ""
if {![info exists :method]} {
  set :method [expr {$post_data eq "" ? "GET" : "POST"}]
}
if {[info exists :url]} {
  :parse_url
} else {
  if {![info exists port]} {:set_default_port $protocol}
  if {![info exists host]} {
    error "either host or url must be specified"
  }
}
if {$protocol eq "https"} {
  package require tls
  if {[info commands ::tls::import] eq ""} {
    error "https request require the Tcl module TLS to be installed\n See e.g. http://tls.sourceforge.net/"
  }
  #
  # Add HTTPs handling
  #
  :mixin add ::xo::Tls
}
if {[catch {:open_connection} err]} {
  :cancel "error during open connection via $protocol to $host $port: $err"
}
  • method (setter)
    

  • open_connection (scripted)
    

    :instvar host port S
set S [socket -async $host $port]
  • parse_url (scripted)
    

    :instvar protocol url host port path
if {[regexp {^(http|https)://([^/]+)(/.*)?$} $url _ protocol host path]} {
  # Be friendly and allow strictly speaking invalid URLs
  # like "http://www.openacs.org"  (no trailing slash)
  if {$path eq ""} {set path /}
  :set_default_port $protocol
  regexp {^([^:]+):(.*)$} $host _ host port
} else {
  error "unsupported or invalid url '$url'"
}
  • path (setter)
    

  • port (setter)
    

  • post_data (setter)
    

  • protocol (setter)
    

  • reply_first_line (scripted)
    

    :instvar S status_code
fconfigure $S -translation crlf
set n [:getLine response]
switch -exact -- $n {
  -2 {:cancel premature-eof; return}
  -1 {:finish; return}
}
if {[regexp {^HTTP/([0-9.]+) +([0-9]+) *} $response _  responseHttpVersion status_code]} {
  :reply_first_line_done
} else {
  :cancel "unexpected-response '$response'"
}
  • reply_first_line_done (scripted)
    

    :header
  • reply_header_done (scripted)
    

    :instvar S
# we have received the header, including potentially the
# content_type of the returned data
array set "" [:get_channel_settings [:content_type]]
fconfigure $S -translation $(translation) -encoding $(encoding)
if {[info exists :content_length]} {
  set :data [read ${:S} ${:content_length}]
} else {
  set :data [read ${:S}]
}
:finish
  • request_done (scripted)
    

    :instvar S
flush $S
:reply_first_line
  • request_header_fields (setter)
    

  • send_POST_data (scripted)
    

    :instvar S post_data
puts -nonewline $S $post_data
:request_done
  • send_request (scripted)
    

    :instvar S post_data host method
if {[catch {
  puts $S "$method [:path] HTTP/1.0"
  puts $S "Host: $host"
  puts $S "User-Agent: [:user_agent]"
  foreach {tag value} [:request_header_fields] {
    #regsub -all \[\n\r\] $value {} value
    #set tag [string trim $tag]
    puts $S "$tag: $value"
  }
  :$method
} err]} {
  :cancel "error send $host [:port]: $err"
  return
}
  • set_default_port (scripted)
    

    switch -- $protocol {
  http  {set :port 80}
  https {set :port 443}
}
  • set_status (scripted)
    

    nsv_set bgdelivery $key [list $newStatus $value]
  • unset_status (scripted)
    

    nsv_unset bgdelivery $key
  • url (setter)
    

  • user_agent (setter)