#<p>
# Provides a rudimentary SOAP server.  Assumes the body of the
#   SOAP request is a single service (with arguments).
#</p>
#<p>
# <b>Author:</b> Steve Wampler (<i>sbw@tapestry.tucson.az.us</i>)
#</p>
#<p>
#  This file is in the <i>public domain</i>.
# <b>Report any errors to the author!</b>
#</p>

package soap

import util
import xml          # From Robert Parlett's class library
import lang

#<p>
# A simple SoapServer.  Really meant to be subclassed.  Only serves
#   procedure calls.
#</p><p>
# Here is a simple server based on this class (the URI is imaginary):
#</p>
#<pre>
# import soap
#
# procedure main()
#     server := SoapServer(URI_GOES_HERE)
#     server.setDebugFile("/dev/null")
#     server.addService("hi",   hi, "Produces a string from args")
#     server.addService("bye", bye, "Produces a table from args")
#     server.addService("guy", guy, "Produces a list from args")
#     server.addSpecialService("why", spcl, "Test of a 'special' service.")
#     msg := server.handleRequest()
#     write(msg)
#     exit(0)
# end
#
# procedure hi(a[])
#     s := ""
#     every s ||:= !a
#     return ("Hi "||s)
# end
#
# procedure bye(a[])
#     s := table()
#     s["a1"] := a[1]
#     s["a2"] := a[2]
#     s["a3"] := a[3]
#     return s
# end
#
# procedure guy(a[])
#     s := list()
#     every put(s := [], !a)
#     return s
# end
#
# procedure spcl(a[])
#     return "&lt;result&gt;&lt;v1&gt;special service called!&lt;/v1&gt;&lt;/result&gt;"
# end
#</pre>
class SoapServer : Object(uri,            # URI of service
                          services,       # Available services
                          servicesHelp,   # Short help messages
                          request,        # Current request
                          specialServices,# Marks services that are 'special'
                          debugFile       # File for debug messages or &null
                         )

   #<p>
   #   Turn on some debugging output by setting a file to which
   #   debug messages are written.  Turn off by setting to <tt>&null</tt>.
   #</p>
   method setDebugFile(f)  # File name or open file.
      if ::type(f) == "string" then {
	 f := ::open(f, "w") | fail
	 }
      debugFile := f
   end

   #<p>
   #   Add a service.
   #</p>
   method addService(sName,    # Name of service
		     func,     # Procedure implementing service
		     helpMsg)   # (Optional) help message
      services[sName] := func
      servicesHelp[sName] := \helpMsg
   end

   #<p>
   #   Add a <i>special</i> service.
   #     A special service is one that can do its own
   #     SOAP-compatible formatting (i.e. handles all formatting
   #     in the response that normally appears <i>within</i>
   #     the SOAP-ENV:Body tags.  (This includes the all-encompassing
   #     <tt>&lt;result&gt;...&lt;/result&gt;</tt> element.)
   #</p>
   method addSpecialService(sName,  # Name of service
			    func,   # Procedure implementing service
			    helpMsg) # (Optional) help message
      addService(sName, func, helpMsg)
      ::insert(specialServices, sName)
   end

   #<p>
   #   Remove a service.
   #</p>
   method delService(sName) # Name of service to remove.
      services[sName] := &null
      ::delete(specialServies, sName)
   end

   #<p>
   # Produce a list of services and any help messages.  Available
   #   automatically through the SOAP server.
   #  <[return a list of service/help message strings]>
   #</p>
   method listServices()
      local aList := [], sName
      every sName := (!::sort(services))[1] do {
	 ::put(aList, ::left(sName,30)||(\servicesHelp[sName] | ""))
	 }
      return aList
   end

   #<p>
   #   Produce the function for service <tt>sName</tt> or fail if
   #   none.
   #   <[returns the named service]>
   #   <[fails if no such service]>
   #</p>
   method getService(sName)    # Name of service
      return \services[sName]
   end

   #<p>
   # Given the name of a service and a list of parameters,
   #   produce the result of invoking that service on those
   #  parameters.
   #  <[returns result of calling <tt>sName</tt> with <tt>aList</tt> args]>
   #</p>
   #<p><i>Internal use only.</i></p>
   method invokeService(sName, # Name of service
			aList)  # List of arguments for service
      return (getService(sName) ! aList)
   end

   #<p>
   # Handle the request.  This is normal way for the server to
   #   to respond to a request.
   #   <[returns request response]>
   #   <i>Has a very simple minded view of a request!</i>
   #</p>
   method handleRequest()
      local request, children, svc, sName, arglist, param, msg
      static Fmt
      initial Fmt := xml::XmlFormatter()

      if request := getRequest() then {
	 debugMsg("Request: ",Fmt.format_document(request,0))
	 children := request.get_children()
	 debugMsg("Children: ",image(children))
	 (svc := (!children), ::type(svc) ~== "string")
	 debugMsg("SVC: ",::image(svc))
	 sName := svc.get_name()
	 sName ?:= 2(skipTo(::upto(':')+1),::tab(0))
	 debugMsg("Name: ",sName)
	 arglist := []
	 every param := !soap::getNonWSChildren(svc) do {
	    ::put(arglist, soap::decode(param))
	    }
	 debugMsg("Param count: ",*arglist)
	 if sName == "listServices" then {
	    return respond(listServices())
	    }
	 else if msg := invokeService(sName, arglist) then {
	    if not ::member(specialServices, sName) then {
	       return respond(msg)
	       }
	    else {
	       return respondSpecial(msg)
	       }
	    }
	 else {
	    return error("SOAP-ENV:Server",
			 "Unknown service '"||sName||"'.")
	    }
	 }
   end

   #<p>
   # Report an error.
   # <[returns result of reporting error]>
   #</p>
   #<p><i>Internal use only.</i></p>
   method error(code,  # SOAP error code
		msg)    # Error message text
      msg := "    <SOAP-ENV:Fault>\n"                            ||
	     "      <faultcode>"||code||"</faultcode>\n"         ||
             "      <faultstring>"||msg||"</faultstring>\n"      ||
             "    </SOAP-ENV:Fault>\n"
      return respondSpecial(msg)
   end

   #<p>
   # <[return the  xml::Element for the current server request.
   #  Discards the outer layers of the SOAP request.]>
   #</p>
   #<p><i>Internal use only.</i></p>
   method getRequest()
      local line, root
      static parser
      initial parser := soap::getXmlParser()

      if ::getenv("REQUEST_METHOD") == "GET" then {
	 line := ::getenv("QUERY_STRING")
	 }
      else {
	 line := ::reads(&input, ::getenv("CONTENT_LENGTH"))
	 }
      debugMsg("Got: '",line,"'")
      root := parser.parse(line).get_root_element()
      return root.search_children("SOAP-ENV:Body")
   end

   #<p>
   # Log a message to a file if told to do so.
   #</p>
   method debugMsg(msg[])   # Arguments are displayed to (non-null) debugfile
      ::write ! ::push(msg, \debugFile)
   end

   # These next methods are internal methods for constructing a response

   #<p>
   # Build a response up in SOAP format.
   #  <[return response suitable for sending out via SOAP]>
   #</p>
   #<p><i>Internal use only.</i></p>
   method respond(response)     # response to convert to SOAP message format
      return respondSpecial(responseMid(response))
   end

   #<p>
   # Respond, assuming the response is already a SOAP-formatted string.
   #  <[return response suitable for sending out via SOAP]>
   #</p>
   #<p><i>Internal use only.</i></p>
   method respondSpecial(response)   # Response in SOAP message format
      local res

      res := soap::soapHead()         ||
	     "  <SOAP-ENV:Body>\n"    ||
             response                 ||
             "  </SOAP-ENV:Body>\n"   ||
             soap::soapTail()
      res := soap::httpWrap(res)
      debugMsg("\nSent:\n", res)
      return res
   end

   #<p>
   # Build the middle part of the message.  Likely to be overridden by
   #   subclasses, as this returns a single, simple value.
   #   <[return <tt>response</tt> converted to SOAP format]>
   #</p>
   #<p><i>Internal use only.</i></p>
   method responseMid(response) # Response to convert to SOAP message format
      local s := "    <result>"
      s ||:= soap::encode(response, "      ")
      s ||:= "    </result>\n"
      return s
   end

#<p>
# Create a new SOAP server.  Services can be supplied now or
#   added later with <tt>addService</tt>.  If added now,
#   <tt>newServices</tt> is a table mapping service names
#   to procedures.
#</p>
initially (newUri,      # URI indentifying server
	   newServices)  # (Optional) table mapping procedures to services
   uri := newUri
   services := \newServices | ::table()
   servicesHelp := ::table()
   specialServices := ::set()
   debugFile := &null
end