Index: openacs-4/packages/soap-gateway/soap-gateway.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/soap-gateway.info,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/soap-gateway.info 17 Oct 2004 05:51:39 -0000 1.1 @@ -0,0 +1,29 @@ + + + + + SOAP Gateway + SOAP Gateway + f + t + soap + + + William Byrne + Nick Carroll + SOAP Gateway marshalls SOAP/HTTP to user defined services + 2004-10-04 + + + + + + + + + + + + + + Index: openacs-4/packages/soap-gateway/lib/demo-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/lib/demo-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/lib/demo-procs.tcl 17 Oct 2004 05:51:51 -0000 1.1 @@ -0,0 +1,83 @@ +ad_library { + + soap-gateway demo routines + + @author William Byrne (WilliamB@ByrneLitho.com) + +} + +# create namespace +namespace eval sg::demo { + + # remove old procs + foreach p [info commands ::sg::demo::*] { + + # remove + rename $p {} + } + + # If there are any authentication requirements for a method in a service, add login + # and logout wrappers for soap::login and soap::logout methods. + # + # This will prevent the SOAP client transport from having to maintain session cookies + # across multiple client SOAP stubs. For example, a SOAP client can log into OpenACS using + # the 'workspace' service. Typically, the SOAP client will fetch the WSDL for the service + # and expose methods to the developer for calling upon methods specified in the WSDL. + # In the case of the 'workspace' service, the user would call the 'login' method. If + # successful, a session cookie is returned to the client and is maintained by the HTTP + # transport. If the user wishes to use the 'demo' service, another client SOAP stub + # would be created referencing the WSDL for the 'demo' service. Since the 'demo' SOAP + # stub is new, it won't have the session data maintained by the 'workspace' stub. There + # are certainly ways to share the session data; however, the process of doing so often + # turns into a science project. + + # workspace login wrapper + ad_proc -public login { + user + password + } { + @author William Byrnec + @idl void Login(string user, string password) + } { + + # call sg library + return [soap::login $user $password] + } + + + # workspace logout wrapper + ad_proc -public logout { + } { + @author William Byrne + @idl void Logout() + } { + # call sg logout + return [soap::logout] + } + + + # define calculate method + ad_proc -public calculate { + expr + } { + + Performs an evaluation of the expression argument. The method attemps to provide some + safety by scanning for procedure notation. If detected, an exception is thrown. + + @author William Byrne + @idl string Calculate(string expr) + } { + + # detect proc bracket + if { [sting first \[ $expr] >= 0 } { + # throw + soap::fault::raise "procedure calls within expression are not allowed!" + } + + # calculate + return [expr $expr] + + } + + +} Index: openacs-4/packages/soap-gateway/lib/interop-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/lib/interop-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/lib/interop-procs.tcl 17 Oct 2004 05:51:51 -0000 1.1 @@ -0,0 +1,116 @@ +ad_library { + + soap-gateway interop routines + + @author William Byrne (WilliamB@ByrneLitho.com) + +} + +# set up interop namespace +namespace eval sg::interop { + + # remove old procs + foreach p [info commands ::sg::interop::*] { + + # remove + rename $p {} + } + + ad_proc -public login { + user + password + } { + Logs the user into OpenACS. The user and password arguments + correspond to the user/password values specified during user registration. The + HTTP transport used for the SOAP Envelope must support cookies for session based + RPC; otherwise, the user will be limited WSDL functions that expose 'invoke' + privileges to 'public'. + + @author William Byrne + @idl void Login(string user, string password) + } { + + # call sg library + return [soap::login $user $password] + } + + ad_proc -public logout { + } { + Logs the current user session out of OpenACS. + + @author William Byrne + @idl void Logout() + } { + # call sg library + return [soap::logout] + } + + ad_proc -public echo_string { + data + } { + @author William Byrne + @idl string EchoString(string data) + } { + + # return test data + return $data + + } + + ad_proc -public echo_integer { + data + } { + @author William Byrne + @idl int EchoInteger(int data) + } { + + # return test data + return $data + + } + + ad_proc -public echo_float { + data + } { + @author William Byrne + @idl float EchoFloat(float data) + } { + + # return test data + return $data + + } + + ad_proc -public echo_long { + data + } { + @author William Byrne + @idl long EchoLong(long data) + } { + # return test data + return $data + + } + + ad_proc -public echo_int64 { + data + } { + @author William Byrne + @idl __int64 EchoInt64(__int64 data) + } { + # return test data + return $data + + } + + ad_proc -public echo_void { + } { + @author William Byrne + @idl void EchoVoid() + } { + + # return nothing + + } + +} Index: openacs-4/packages/soap-gateway/lib/workspace-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/lib/workspace-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/lib/workspace-procs.tcl 17 Oct 2004 05:51:51 -0000 1.1 @@ -0,0 +1,220 @@ +ad_library { + + The workspace service provides a set of user workspace functions that + include the ability to log in and out of the OpenACS system. In order to take + advantage of session based SOAP RPC, the HTTP transport used by the client must + support cookies; otherwise, the user will be limited to methods that have + invoke privileges on the Public user. + + @author William Byrne (WilliamB@ByrneLitho.com) + +} + +# set up workspace namespace and exports +namespace eval sg::workspace { + + # remove old procs + foreach p [info commands ::sg::workspace::*] { + + # remove + rename $p {} + } + + + ad_proc -public login { + user + password + } { + Logs the user into OpenACS. The user and password arguments + correspond to the user/password values specified during user registration. The + HTTP transport used for the SOAP Envelope must support cookies for session based + RPC; otherwise, the user will be limited WSDL functions that expose 'invoke' + privileges to 'public'. + + @author William Byrne + @idl void Login(string user, string password) + } { + + # call soap::login procedure + return [soap::login $user $password] + } + + ad_proc -public logout { + } { + Logs the current user session out of OpenACS. + + @author William Byrne + @idl void Logout() + } { + + # call sg logout + return [soap::logout] + } + + ad_proc -public set_name { + firstname + lastname + } { + Changes the firstname and lastname of the user specified during the 'login' operation. + + @author William Byrne + @idl void SetName(string firstname, string lastname) + } { + + # get user + set user_id [ad_conn user_id] + + # require write permission on user + soap::server::require_permission $user_id write + + # verify args ??? + + db_dml {} "update persons + set first_names = :firstname, + last_name = :lastname + where person_id = :user_id" + + } + + ad_proc -public get_name { + } { + Returns the first and last name of the user currently logged in. + + @author William Byrne + @idl string GetName() + } { + + # get user + set user_id [ad_conn user_id] + + # require write permission on user + soap::server::require_permission $user_id read + + db_1row {} { + select first_names, last_name, email, + case when url is null then 'http://' else url end as url, + screen_name + from cc_users + where user_id=:user_id + } + + # return name + return [string trim "$first_names $last_name"] + + } + + ad_proc -private has_bio { + user_id + {data {}} + } { + Utility procedure that returns whether user has bio record + + @author William Byrne + } { + + # grafted from subsite + set retval [db_0or1row grab_bio "select attr_value as bio_old + from acs_attribute_values + where object_id = :user_id + and attribute_id = + (select attribute_id + from acs_attributes + where object_type = 'person' + and attribute_name = 'bio')"] + + # test + if { $data != {} } { + + # go up one frame + upvar $data bio + + if [soap::server::lib::true $retval] { + + # set it + set bio $grab_bio + + } else { + + # clear it + set bio {} + + } + + } + + # return status + return $retval + } + + ad_proc -public get_bio { + } { + Returns the users biography. + + @author William Byrne + @idl string GetBio() + + } { + + # get user + set user_id [ad_conn user_id] + + # require write permission on user + soap::server::require_permission $user_id read + + # has bio will fill optional data arg with biography + has_bio $user_id bio + + # return bio + return $bio + + } + + ad_proc -public set_bio { + bio + } { + Updates the users biography. + + @author William Byrne + @idl void SetBio(string bio) + + } { + + # get user + set user_id [ad_conn user_id] + + # require write permission on user + soap::server::require_permission $user_id read + + # verify length + soap::check_str_len $bio 4000 "Your biography is too long. Please limit it to 4000 characters" + + # has bio ? + if [has_bio $user_id] { + + # grafted from subsite - update + db_dml update_bio "update acs_attribute_values + set attr_value = :bio + where object_id = :user_id + and attribute_id = + (select attribute_id + from acs_attributes + where object_type = 'person' + and attribute_name = 'bio')" + + + } else { + + # grafted from subsite - insert + db_dml insert_bio "insert into acs_attribute_values + (object_id, attribute_id, attr_value) + values + (:user_id, (select attribute_id + from acs_attributes + where object_type = 'person' + and attribute_name = 'bio'), :bio)" + + } + + } + +} \ No newline at end of file Index: openacs-4/packages/soap-gateway/sql/postgresql/soap-gateway-create.sql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/sql/postgresql/soap-gateway-create.sql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/sql/postgresql/soap-gateway-create.sql 17 Oct 2004 05:51:52 -0000 1.1 @@ -0,0 +1,571 @@ +-- packages/soap-gateway/sql/postgresql/soap-gateway-create.sql +-- +-- @author WilliamB@ByrneLitho.com +-- @creation-date 2002-12-22 +-- @cvs-id $Id: soap-gateway-create.sql,v 1.1 2004/10/17 05:51:52 ncarroll Exp $ +-- +-- + +-- clear existing +--\i soap-gateway-drop.sql +--\q +create function inline_0 () +returns integer as ' +begin + PERFORM acs_object_type__create_type ( + ''wsdl_namespace'', -- object_type + ''WSDL Namespace'', -- pretty_name + ''WSDL Namespaces'', -- pretty_plural + ''acs_object'', -- supertype + ''sg_namespaces'', -- table_name + ''namespace_id'', -- id_column + null, -- package_name + ''f'', -- abstract_p + null, -- type_extension_table + ''sg_namespaces__name'' -- name_method + ); + + return 0; +end;' language 'plpgsql'; + +select inline_0 (); + +drop function inline_0 (); + +create function inline_1 () +returns integer as ' +begin + PERFORM acs_object_type__create_type ( + ''wsdl_method'', -- object_type + ''WSDL Method'', -- pretty_name + ''WSDL Methods'', -- pretty_plural + ''acs_object'', -- supertype + ''sg_methods'', -- table_name + ''method_id'', -- id_column + null, -- package_name + ''f'', -- abstract_p + null, -- type_extension_table + ''sg_methods__name'' -- name_method + ); + + return 0; +end;' language 'plpgsql'; + +select inline_1 (); + +drop function inline_1 (); + +-- define invoke moniker +create view sg_invoke_moniker as + select 'invoke' as invoke from dual; + +create function inline_2 () +returns integer as ' +declare + v_invoke varchar; +begin + select invoke into v_invoke from sg_invoke_moniker; + + -- create privileges + perform acs_privilege__create_privilege(v_invoke); + + -- bind privileges to global names + perform acs_privilege__add_child(''admin'',v_invoke); + + return 0; +end;' language 'plpgsql'; +select inline_2(); +drop function inline_2(); + + + +create table sg_namespaces ( + namespace_id integer + constraint sg_namespaces_namespace_id_fk + references acs_objects(object_id) + constraint sg_namespaces_namespace_id_pk + primary key, + service varchar(255) + constraint sg_namespaces_service_nn + not null unique check(trim(service) <> ''), + uri varchar(255) + constraint sg_namespaces_uri_nn + not null, + dirty boolean + default 't' + constraint sg_namespaces_dirty_nn + not null, + notes varchar(1024) +); + +create index sg_namespaces_idx1 on sg_namespaces(service); + +create table sg_methods ( + method_id integer + constraint sg_methods_method_id_fk + references acs_objects(object_id) + constraint sg_methods_namespace_id_pk + primary key, + namespace_id integer + constraint sg_methods_namespace_id_fk + references sg_namespaces(namespace_id), + method varchar(255) + constraint sg_methods_method_nn + not null check(trim(method) <> ''), + idl varchar(255) + constraint sg_methods_idl_nn + not null, + idl_style varchar(32) + constraint sg_methods_idl_style_nn + not null, + proc varchar(255) + constraint sg_methods_proc_nn + not null, + notes varchar(1024) +); + +-- oddity fixup for lower case on index +create function sg_unique(integer,varchar) +returns text as ' +begin + return '''' || $1 || ''-'' || lower($2); +end;' language 'plpgsql' with(iscachable);; + + +create unique index sg_methods_idx1 on sg_methods(sg_unique(namespace_id, method)); + + +create table sg_libraries ( + library_id integer not null primary key, + path varchar(255) not null unique +); + +-- +-- sequences +-- + +create sequence sg_library_id_seq start 1000; + +-- +-- functions +-- + +-- get namespace id +create function sg_namespace__get_id(varchar) +returns integer as ' +declare + p_service alias for $1; + + v_namespace_id sg_namespaces.namespace_id%type; +begin + + -- nullify + v_namespace_id = null; + + -- get namespace count for id + select into v_namespace_id namespace_id + from sg_namespaces + where service = p_service; + + -- fix up + if v_namespace_id is null then + v_namespace_id = -1; + end if; + + -- return object id + return v_namespace_id; + +end;' language 'plpgsql'; + +-- create new namespace +create function sg_namespace__new(varchar, varchar, varchar, timestamptz, integer, varchar, integer) +returns integer as ' +declare + p_service alias for $1; + p_uri alias for $2; + p_notes alias for $3; + + p_creation_date alias for $4; -- default now() + p_creation_user alias for $5; + p_creation_ip alias for $6; + p_context_id alias for $7; + + v_namespace_id sg_namespaces.namespace_id%type; +begin + + -- create new base object + v_namespace_id := acs_object__new ( + null, + ''wsdl_namespace'', + p_creation_date, + p_creation_user, + p_creation_ip, + p_context_id + ); + + -- add to namespace table + insert into sg_namespaces + (namespace_id, service, uri, dirty, notes) + values + (v_namespace_id, p_service, p_uri, ''t'', p_notes); + + -- create admin permission + PERFORM acs_permission__grant_permission( + v_namespace_id, + p_creation_user, + ''admin'' + ); + + -- return new object id + return v_namespace_id; + +end;' language 'plpgsql'; + +create function sg_namespace__update(integer, varchar, varchar, varchar) +returns integer as ' +declare + p_namespace_id alias for $1; + p_service alias for $2; + p_uri alias for $3; + p_notes alias for $4; + +begin + + -- update row values + update sg_namespaces + set + service = p_service, + uri = p_uri, + dirty = ''t'', + notes = p_notes + where + namespace_id = p_namespace_id; + + -- return something + return 0; + +end;' language 'plpgsql'; + +-- check namespace id +create function sg_namespace__exists(integer) +returns integer as ' +declare + p_namespace_id alias for $1; + v_record record; +begin + + -- get namespace count for id + select into v_record count(*) + from sg_namespaces + where namespace_id = p_namespace_id; + + -- test + return v_record.count; + +end;' language 'plpgsql'; + +-- remove namespace and child methods +create function sg_namespace__delete (integer) +returns integer as ' +declare + p_namespace_id alias for $1; + v_object_rec record; +begin + + -- verify id + if sg_namespace__exists(p_namespace_id) = 0 then + raise EXCEPTION ''Invalid namespace id: %'', p_namespace_id; + end if; + + -- clean up permissions for namespace methods + delete from acs_permissions + where object_id in ( + select method_id from sg_methods + where namespace_id = p_namespace_id + ); + + -- clean up permissions for namespace + delete from acs_permissions + where object_id = p_namespace_id; + + -- remove method objects + for v_object_rec in select method_id from sg_methods where namespace_id = p_namespace_id + loop + perform acs_object__delete( v_object_rec.method_id ); + end loop; + + PERFORM acs_object__delete(p_namespace_id); + + -- remove methods + delete from sg_methods + where namespace_id = p_namespace_id; + + -- remove namespace + delete from sg_namespaces + where namespace_id = p_namespace_id; + + return 0; + +end;' language 'plpgsql'; + + +-- create new method +create function sg_method__new(integer, varchar, varchar, varchar, varchar, varchar, timestamptz, integer, varchar, integer) +returns integer as ' +declare + p_namespace_id alias for $1; + p_method alias for $2; + p_idl alias for $3; + p_idl_style alias for $4; + p_proc alias for $5; + p_notes alias for $6; + + p_creation_date alias for $7; -- default now() + p_creation_user alias for $8; + p_creation_ip alias for $9; + p_context_id alias for $10; + + v_method_id integer; +begin + + -- create new base object + v_method_id := acs_object__new ( + null, + ''wsdl_method'', + p_creation_date, + p_creation_user, + p_creation_ip, + p_context_id + ); + + -- add to method table + insert into sg_methods + (method_id, namespace_id, method, idl, idl_style, proc, notes) + values + (v_method_id, p_namespace_id, p_method, p_idl, p_idl_style, p_proc, p_notes); + + -- create admin permission + PERFORM acs_permission__grant_permission( + v_method_id, + p_creation_user, + ''admin'' + ); + + -- return new object id + return v_method_id; + +end;' language 'plpgsql'; + +-- update method +create function sg_method__update(integer, varchar, varchar, varchar, varchar, varchar) +returns integer as ' +declare + p_method_id alias for $1; + p_method alias for $2; + p_idl alias for $3; + p_idl_style alias for $4; + p_proc alias for $5; + p_notes alias for $6; + +begin + + -- update row values + update sg_methods + set + method = p_method, + idl = p_idl, + idl_style = p_idl_style, + proc = p_proc, + notes = p_notes + where + method_id = p_method_id; + + -- return something + return 0; + +end;' language 'plpgsql'; + +-- check method id +create function sg_method__exists(integer) +returns integer as ' +declare + p_method_id alias for $1; + v_record record; +begin + + -- get method count for id + select into v_record count(*) + from sg_methods + where method_id = p_method_id; + + -- test + return v_record.count; + +end;' language 'plpgsql'; + +-- remove method +create function sg_method__delete (integer) +returns integer as ' +declare + p_method_id alias for $1; +begin + + -- verify id + if sg_method__exists(p_method_id) = 0 then + raise EXCEPTION ''Invalid method id: %'', p_method_id; + end if; + + + -- clean up permissions for method + delete from acs_permissions + where object_id = p_method_id; + + -- remove method object + perform acs_object__delete(p_method_id); + + -- remove methods + delete from sg_methods + where method_id = p_method_id; + + return 0; + +end;' language 'plpgsql'; + +-- create new library +create function sg_library__new(varchar) +returns integer as ' +declare + p_path alias for $1; + + v_library_id sg_libraries.library_id%type; +begin + + -- create next val + v_library_id = nextval(''sg_library_id_seq''); + + -- add to library table + insert into sg_libraries + (library_id, path) + values + (v_library_id, p_path); + + -- return id + return v_library_id; + +end;' language 'plpgsql'; + +-- update library +create function sg_library__update(integer, varchar) +returns integer as ' +declare + p_library_id alias for $1; + p_path alias for $2; +begin + + -- update row values + update sg_libraries + set + path = p_service + where + library_id = p_library_id; + + -- return something + return 0; + +end;' language 'plpgsql'; + +-- remove library +create function sg_library__delete (integer) +returns integer as ' +declare + p_library_id alias for $1; +begin + + -- remove + delete from sg_libraries + where library_id = p_library_id; + + return 0; + +end;' language 'plpgsql'; + +-- returns namespace name +create function sg_namespaces__name (integer) +returns varchar as ' +declare + id alias for $1; + v_name sg_namespaces.service%TYPE; +begin + select service into v_name + from sg_namespaces + where namespace_id = id; + + return v_name; +end;' language 'plpgsql'; + +-- returns method name +create function sg_methods__name (integer) +returns varchar as ' +declare + id alias for $1; + v_name sg_methods.method%TYPE; +begin + select method into v_name + from sg_methods + where method_id = id; + + return v_name; +end;' language 'plpgsql'; + +-- forces namespace to dirty state for WSDL regen +create function sg_namespaces__dirty(integer) +returns integer as ' +declare + id alias for $1; +begin + update sg_namespaces + set dirty = ''t'' + where namespace_id = id; + return 0; +end;' language 'plpgsql'; + +-- trigger functions +create function sg_methods__itrg () +returns opaque as ' +begin + perform sg_namespaces__dirty(new.namespace_id); + return new; +end;' language 'plpgsql'; + +create function sg_methods__dtrg () +returns opaque as ' +begin + perform sg_namespaces__dirty(old.namespace_id); + return old; +end;' language 'plpgsql'; + +create function sg_methods__utrg () +returns opaque as ' +begin + perform sg_namespaces__dirty(new.namespace_id); + if new.namespace_id <> old.namespace_id then + perform sg_namespacs__dirty(old.namespace_id); + end if; + return old; +end;' language 'plpgsql'; + +-- create triggers +create trigger sg_methods__itrg after insert on sg_methods +for each row execute procedure sg_methods__itrg (); + +create trigger sg_methods__dtrg after delete on sg_methods +for each row execute procedure sg_methods__dtrg (); + +create trigger sg_methods__utrg after update on sg_methods +for each row execute procedure sg_methods__utrg (); + +-- post intallation configuration +select sg_library__new('packages/soap-gateway/lib/workspace-procs.tcl') from dual; +select sg_library__new('packages/soap-gateway/lib/interop-procs.tcl') from dual; + + Index: openacs-4/packages/soap-gateway/sql/postgresql/soap-gateway-drop.sql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/sql/postgresql/soap-gateway-drop.sql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/sql/postgresql/soap-gateway-drop.sql 17 Oct 2004 05:51:52 -0000 1.1 @@ -0,0 +1,100 @@ +-- packages/soap-gateway/sql/postgresql/soap-gateway-drop.sql +-- +-- @author WilliamB@ByrneLitho.com +-- @creation-date 2002-12-22 +-- @cvs-id $Id: soap-gateway-drop.sql,v 1.1 2004/10/17 05:51:52 ncarroll Exp $ +-- +-- + +--drop permissions +delete from acs_permissions where object_id in (select method_id from sg_methods); +delete from acs_permissions where object_id in (select namespace_id from sg_namespaces); +delete from acs_permissions where object_id in (select object_id from acs_objects where object_type in ('wsdl_namespace','wsdl_method')); +delete from acs_permissions where object_id in (select package_id from apm_packages where package_key in ('soap-gateway')); + +-- clear objects +create function inline_0 () +returns integer as ' +declare + object_rec record; +begin + for object_rec in select object_id from acs_objects where object_type in (''wsdl_namespace'',''wsdl_method'') + loop + perform acs_object__delete( object_rec.object_id ); + end loop; + + return 0; +end;' language 'plpgsql'; + +select inline_0 (); +drop function inline_0 (); + +create function inline_2 () +returns integer as ' +declare + v_invoke varchar; +begin + select invoke into v_invoke from sg_invoke_moniker; + + -- unbind privileges to global names + perform acs_privilege__remove_child(''admin'', v_invoke); + + -- drop privileges + perform acs_privilege__drop_privilege(v_invoke); + + + return 0; +end;' language 'plpgsql'; +select inline_2(); +drop function inline_2(); + + +-- drop triggers +drop trigger sg_methods__itrg on sg_methods; +drop trigger sg_methods__dtrg on sg_methods; +drop trigger sg_methods__utrg on sg_methods; + +-- drop functions +drop function sg_namespace__get_id(varchar); +drop function sg_namespace__new(varchar, varchar, varchar, timestamptz, integer, varchar, integer); +drop function sg_namespace__update(integer, varchar, varchar, varchar); +drop function sg_namespace__exists(integer); +drop function sg_namespace__delete (integer); +drop function sg_method__new(integer, varchar, varchar, varchar, varchar, varchar, timestamptz, integer, varchar, integer); +drop function sg_method__update(integer, varchar, varchar, varchar, varchar, varchar); +drop function sg_method__exists(integer); +drop function sg_method__delete (integer); +drop function sg_namespaces__name (integer); +drop function sg_methods__name (integer); +drop function sg_namespaces__dirty(integer); +drop function sg_methods__itrg(); +drop function sg_methods__dtrg(); +drop function sg_methods__utrg(); +drop function sg_library__new(varchar); +drop function sg_library__update(integer, varchar); +drop function sg_library__delete(integer); +drop function sg_unique(integer,varchar); + +-- drop tables +drop table sg_methods; +drop table sg_namespaces; +drop table sg_libraries; + +-- drop sequences +drop sequence sg_library_id_seq; + +-- drop views +drop view sg_invoke_moniker; + +-- drop attributes + +-- drop type +select acs_object_type__drop_type( + 'wsdl_namespace', + 't' + ); +select acs_object_type__drop_type( + 'wsdl_method', + 't' + ); + Index: openacs-4/packages/soap-gateway/tcl/soap-fault-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-fault-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-fault-procs.tcl 17 Oct 2004 05:51:52 -0000 1.1 @@ -0,0 +1,239 @@ +ad_library { + Tcl API for SOAP Faults. + + @author William Byrne (WilliamB@ByrneLitho.com) + @author Nick Carroll (ncarroll@ee.usyd.edu.au) + @creation-date 2004-09-24 + @cvs-id $Id: soap-fault-procs.tcl,v 1.1 2004/10/17 05:51:52 ncarroll Exp $ +} + + +namespace eval soap::fault {} + + +ad_proc -public soap::fault::assert { + test + msg +} { + @param test + @param msg +} { + # calculate + if [catch {set test [uplevel expr $test] } ] { + # throw + soap::fault::raise "Assertion\ntest: $test\n$msg" + } + + # test + if { [string is integer -strict $test] == 0 || $test == 0 } { + # throw + soap::fault::raise "Assertion\ntest: $test\n$msg" + } +} + + +ad_proc -public soap::fault::raise { + msg + {code 500} +} { + @param msg + @param code Default code set to 500. +} { + + # throw + error "SOAP Gateway Error\n$msg" {} $code +} + + +ad_proc -public soap::fault::unauthorized { + {msg "Access Denied"} +} { + @param msg +} { + + # throw + soap::fault::raise "$msg" 401 +} + + +ad_proc -public soap::fault::unsupported { + msg +} { + @param msg +} { + + # throw + soap::fault::raise "$msg" 501 +} + + +ad_proc -private soap::fault::generate_fault { + msg + {ver 1.1} +} { + Generates a fault response based on the specified message. + + @param msg The message to be sent back to the client. + @param ver The version of SOAP that the message should be based on. + @return Returns a fault response SOAP message. +} { + # get version namespace + set version [soap::server::get_version_namespace $ver] + + # construct xml doc object + set doc [dom createDocument env:Envelope] + + # create root node: "env:Envelope" + set env [$doc documentElement] + + # define namespace atts into node + $env setAttribute xmlns:env $version + + # create Body node - "env:Envelope/env:Body" + set body [$env appendChild [$doc createElement env:Body]] + + # create Fault node - "env:Envelope/env:Body/env:Fault" + set fault [$body appendChild [$doc createElement env:Fault]] + + # test version + if { $ver == "1.1" } { + + # create faultcode node + # env:Envelope/env:Body/env:Fault/env:faultcode + $fault appendXML "env:Client" + + # create faultstring node + # env:Envelope/env:Body/env:Fault/env:faultstring + $fault appendXML "$msg" + + } else { + + # do v1.2 + + # create Code node and Value as a sub node of Code + # env:Envelope/env:Body/env:Fault/env:Code + # env:Envelope/env:Body/env:Fault/env:Code/env:Value + $fault appendXML " + + env:Sender + " + + # create Reason node + # env:Envelope/env:Body/env:Fault/env:Reason + # define lang attr into Reason node + $fault appendFromList [list env:Reason {xml:lang en-US} {}] + } + + # render xml into result string + return [$env asXML] +} + +ad_proc -private soap::fault::generate_misunderstood { + namespaces + {ver 1.1} +} { + Generates a misunderstood fault response based on the + specified namespaces. + + @param namespaces The message to be sent back to the client. + @param ver The version of SOAP that the message should be based on. + @return Returns a misunderstood fault response SOAP message. +} { + # set envelope version + set version [soap::server::get_version_namespace $ver] + + # construct xml doc object + set doc [dom createDocument env:Envelope] + + # create root node: "env:Envelope" + set env [$doc documentElement] + + # define namespace atts into node + $env setAttribute xmlns:env $version + $env setAttribute xmlns:flt http://www.w3.org/2003/05/soap-faults + + # create Header node - "env:Envelope/env:Header" + set header [$env appendChild [$doc createElement env:Header]] + + # loop through namespaces and add + foreach ns $namespaces { + # safety + if { [llength $ns] > 1 } { + # add child + set mu [$header appendChild [$doc createElement flt:Misunderstood]] + + # get qname + set qname [lindex $ns 0] + + # split off namespace prefix + set parts [split $qname :] + + # test + if { [llength $parts] > 1 } { + # get prefix + set prefix [lindex $parts 0] + + # get name + set name [lindex $parts 1] + } else { + # generate prefix + append auto x + + # set prefix to auto + set prefix $auto + + # set name to qname + set name $qname + } + + # add name attr + $mu setAttribute qname "$prefix:$name" + + # add namespace + $mu setAttribute "xmlns:$prefix" [lindex $ns 1] + } + } + + # create Body node - "env:Envelope/env:Body" + set body [$env appendChild [$doc createElement env:Body]] + + # create Fault node - "env:Envelope/env:Body/env:Fault" + set fault [$body appendChild [$doc createElement env:Fault]] + + # test version + if { $ver == "1.1" } { + + # create faaultcode node + #env:Envelope/env:Body/env:Fault/env:faultcode + $fault appendXML "env:MustUnderstand" + + # create faultstring node + # env:Envelope/env:Body/env:Fault/env:faultstring + $fault appendXML "One or more mandatory headers not understood" + + } else { + + # do v1.2 + + # create Code node + # env:Envelope/env:Body/env:Fault/env:Code + # env:Envelope/env:Body/env:Fault/env:Code/env:Value + $fault appendXML " + + env:MustUnderstand + " + + # create Reason node + # env:Envelope/env:Body/env:Fault/env:Reason + set reason [$fault appendChild [$doc createElement env:Reason]] + + # define lang attr into Reason node + $reason setAttribute xml:lang "en-US" + + # set message for env:Reason. + $reason appendChild [$doc createTextNode "One or more mandatory headers not understood"] + } + + # render xml into result string + return [$env asXML] +} \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-init.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-init.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-init.tcl 17 Oct 2004 05:51:53 -0000 1.1 @@ -0,0 +1,10 @@ +ad_library { + + soap-gateway init library routines + + @author William Byrne (WilliamB@ByrneLitho.com) + +} + +# schedule a one time directory scan for service source files +ad_schedule_proc -thread t -once t 5 soap::server::lib::boot_libraries \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-procs-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-procs-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-procs-postgresql.xql 17 Oct 2004 05:51:53 -0000 1.1 @@ -0,0 +1,51 @@ + + + + postgresql7.1 + + + + select proc + from sg_methods + where namespace_id = :namespace_id + order by method_id + + + + + + select service from sg_namespaces; + + + + + + select package_id from apm_packages where package_key = 'soap-gateway' + + + + + + select sg_namespace__exists(:namespace_id); + + + + + + select sg_method__exists(:method_id) + + + + + + select 0 + sg_namespace__delete(:namespace_id); + + + + + + select 0 + sg_method__delete(:method_id); + + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-procs.tcl 17 Oct 2004 05:51:53 -0000 1.1 @@ -0,0 +1,852 @@ +ad_library { + SOAP utils API. + + Based on William Byrne's soap-gateway implementation. + + @author William Byrne (WilliamB@ByrneLitho.com) + @author Nick Carroll (ncarroll@ee.usyd.edu.au) + @creation-date 2004-09-24 + @cvs-id $Id: soap-procs.tcl,v 1.1 2004/10/17 05:51:53 ncarroll Exp $ +} + + +namespace eval soap {} + +# Libraries in the lib directory must run in the sg namespace. +namespace eval sg {} + + +ad_proc -public soap::check_str_len { + string + length + {warning {string is too long}} +} { + Verifies the string does not exceed length + + @param string + @param length + @param warning +} { + if { [string length $string] > $length } { + # throw + soap::fault::raise $warning + } +} + + +# create login wrapper for sg services +ad_proc -public soap::login { + user + password +} { + @param user + @param password +} { + # normalize id + set email [string tolower $user] + + # search for + set result [db_0or1row user_login_user_id_from_email { + select user_id, member_state, email_verified_p + from cc_users + where email = :email}] + + # good house keeping + db_release_unused_handles + + # verify + if { $result == 0 } { + # rejected + soap::fault::unauthorized "Access Denied\n$email not registered" + } + + # again + if { $member_state != "approved" || $email_verified_p == "f" } { + # rejected + soap::fault::unauthorized "Access Denied\nMember: $member_state\ne-mail: $email_verified_p" + } + + # and again + if { ![ad_check_password $user_id $password] } { + # rejected + soap::fault::unauthorized "Access Denied\nInvalid user or password" + } + + # is this necessary ??? + ad_user_logout + + # log user + ad_user_login -forever=1 $user_id + + # return 0 + return 0 +} + + +# create logout wrapper for sg services +ad_proc -public soap::logout { +} { + @author William Byrne +} { + # clear cookies + ad_user_logout +} + + +ad_proc -private soap::method_check { + method_id +} { + @param method_id +} { + # exec db + set exists [db_string method_exists {} -default 0] + + # test result + if { $exists == 0 || [string is integer $exists] != 1 } { + # failed, throw + soap::fault::raise "invalid method id: $namespace_id" + } + # valid +} + + +ad_proc -public soap::namespace_delete { + namespace_id +} { + @param namespace_id +} { + db_exec_plsql namespace_delete {} +} + + +ad_proc -public soap::method_delete { + method_id +} { + @param method_id +} { + # db update + db_exec_plsql delete_method {} +} + + +ad_proc -public soap::package_id { + {-throw 1} +} { + @author William Byrne +} { + # try and get id + set pid [apm_package_id_from_key soap-gateway] + + # test + if { $pid != 0 } { + # done + return $pid + } + + # memoize got fed bad stuff - clear it + util_memoize_flush_regexp "apm_package_id_from_key_mem soap-gateway" + + # try again + set pid [apm_package_id_from_key soap-gateway] + + # test + if { $pid != 0 } { + # done + return $pid + } + + # crap - get connection + set pid [ad_conn package_id] + + # verify + if [string equal [apm_package_key_from_id $pid] soap-gateway] { + #done + return $pid + } + + # how 'bout the db + set pid [db_string select_pid {} -default 0] + + # test + if { $pid != 0 } { + # done + return $pid + } + + # throw + if [soap::server::lib::true $throw] { + soap::fault::raise "Cannot get package id for soap-gateway" + } + + # return error + return 0 +} + + +ad_proc -private soap::get { + {-set sg_properties} + property +} { + @param property +} { + # check set + if ![nsv_exists $set $property] { + # return empty + return {} + } + + # get em + return [nsv_get $set $property] +} + + +ad_proc -private soap::namespace_get_names { +} { + @author William Byrne +} { + # init + set names [list] + + # loop through namespaces + db_foreach select_services {} { + # append name + lappend names $service + } + + # return names + return $names +} + + +ad_proc -private soap::query_services { + {-unpublished 0} + {-published 1} + +} { + @author William Byrne +} { + + # get active services + set services [soap::namespace_get_names] + + # test for request + if $unpublished { + # decl unpublished list + set unpub [list] + + # create lower case services + set lowercase_services [string tolower $services] + + # get all namespaces under ::sg + foreach service [namespace children ::sg] { + # get child portion of namespace only - skip + # '::sg::' portion of string + set child [namespace tail $service] + + # search for existing + if { [lsearch $lowercase_services [string tolower $child]] < 0 } { + # add to unpublished list + lappend unpub $child + } + } + + # want all + if $published { + # add to services + return [concat $services $unpub] + } else { + # return list + return $unpub + } + } + + # return services list + return $services +} + + +ad_proc -private soap::get_idl_help { +} { + @author William Byrne +} { + + # return simple instructions + set help { +

+ Use "C" style function syntax. Data type map: + + + + + + + +
Data TypeXML Schema
char, char[], stringxsd:string
int, longxsd:int
float, doublexsd:double
__int64xsd:long
void-
+

+ } +} + + +ad_proc -private soap::check_symbol { + symbol +} { + @param symbol +} { + + # setup reg expr + set r {(^[^a-zA-Z]*)([a-zA-Z][a-zA-Z0-9_]*)([^a-zA-Z0-9_]*$)} + + # call + set e [regexp $r $symbol {} a b c] + + # test - requiring symbol not to exceed 64 characters ??? + if { + $e == 0 || + [string length $a] > 0 || + [string length $b] > 64 || + [string length $c] > 0 + } { + # no good + soap::fault::raise "Invalid symbol: '$symbol'" + } +} + + +ad_proc -private soap::service_from_uri { + uri +} { + @author William Byrne +} { + + # expects format similar to that returned + # from soap::wsdl::build_namespace_uri + + # skip protocol scheme + set offset [string first {://} $uri] + + # found ? + if { $offset >= 0 } { + # strip scheme + set uri [string range $uri [expr $offset + 3] end] + } + + # split sub domains and return first + return [llindex [split $uri .] 0] +} + + +ad_proc -private soap::get_base_url { +} { + @author William Byrne +} { + + # calc href base + set base [ad_conn package_url] + + # verify we're in a soap-gateway site + if { ![string equal [ad_conn package_key] "soap-gateway"] } { + # force to apm registration + set base [apm_package_url_from_key soap-gateway] + } + + # test for problems + if { $base == {} } { + # force to install mode + set base {/soap/} + } + + # return it + return $base +} + + +ad_proc -private soap::get_doc_elements { + {-service {}} + proc +} { + @param proc +} { + # test for service arg + if { $service != {} } { + # build full path + set proc [format "::sg::%s::%s" $service $proc] + } + + # try and get elements + if [catch { + # try + set elements [nsv_get api_proc_doc $proc] + }] { + # failed - strip off leading namespace qualifier + set elements [nsv_get api_proc_doc [string range $proc 2 end]] + } + + # return elements + return $elements +} + + +ad_proc -private soap::get_source_procs { + {-private 0} + {-local 0} + service +} { + Returns a list of procedures within the tcl namespace + formulated by sg::::* + + @param service +} { + # decl unpublished list + set procs [list] + + # safe fetch + catch { + # get methods + set procs [info commands [format "::sg::%s::*" $service]] + } + + # decl result + set result [list] + + # loop through source procs + foreach proc $procs { + + # test for public + set public 0 + + # safe + catch { + + # get proc doc elements + array set doc_elements [nsv_get api_proc_doc \ + [string range $proc 2 end]] + + # assign + set public $doc_elements(public_p) + } + + # test + if { $public || $private } { + # test for local (no namespace) + if [soap::server::lib::true $local] { + # get last element after :: + regexp {([^:]+$)} $proc {} proc + } + # add to list + lappend result $proc + } + } + + # return procs + return $result +} + + +ad_proc -private soap::get_source_idl { + proc +} { + Returns the idl of a procedure. If the procedure exists, + an attempt is made to return @idl description. If @idl doesn't + exists, the idl is formulated from the procedures args. If + the procedure doesn't exists, an empty value is returned. + + @param proc +} { + # build formal name + set formal $proc; #[format "::sg::%s::%s" $service $proc] + + # verify + if { [info commands $formal] == {} } { + # let's return empty string to signal error + soap::fault::raise "Cannot get idl for invalid procedur: $proc" + } + + # decl idl + set idl {} + + # safe + catch { + # get the documentenation array for the method + array set doc_elements [soap::get_doc_elements $formal] + + # get the @idl value and remove curlies via 'join' + set idl [join $doc_elements(idl)] + } + + # test idl + if { $idl == {} } { + + # build from tcl info + + # decl temp + set args2 {} + + # the default idl will always return a string + # and each arg will be type string + foreach arg [info args $formal] { + + # first time + if { $args2 == {} } { + # assign + set args2 "string $arg" + } else { + # add to + append args2 ", string $arg" + } + } + + # remove namespace from proc + set proc [namespace tail $proc] + + # finish + set idl [format "string %s(%s)" $proc $args2] + } + + # return whatever we got + return $idl +} + + +ad_proc -private soap::get_source_idls { + service +} { + Returns a list of idls for public procedures defined + within the sg:::: namespace. + + @see soap::get_source_idl + @param service +} { + # get source procs for service + set procs [soap::get_source_procs $service] + + # decl result list + set result [list] + + # loop though procs + foreach proc $procs { + # get idl for proc + lappend result [soap::get_source_idl $proc] + } + + # return list + return $result +} + + +ad_proc -private soap::method_get_procs { + namespace_id +} { + @param namespace_id +} { + # init + set procs [list] + + db_foreach select_procs {} { + # append method proc + lappend procs $proc + } + + # return methods + return $procs +} + + +ad_proc -private soap::diff_methods { + {-same 0} + service +} { + Compares the published service methods to those in the source file + @param service +} { + # decl unpublished list + set procs [soap::get_source_procs $service] + + # decl published list + set methods [list] + set idls [list] + + # get namespace id + set nid [soap::server::namespace_get_id $service] + + # verify + if { $nid >= 0 } { + + # get published method Tcl proc bindings (proc symbol in db); + set bindings [soap::method_get_procs $nid] + + # and their idls + set idls [soap::wsdl::method_get_idls $nid] + } + + # decl history list + set history [list] + + # decl diff array + array set diffs [list] + + # decl short names list for procs + set shorts [list] + + # get idl parser expression for method - "C" syntax + set method_expr [soap::wsdl::get_style_parser_expr C] + set arg_expr [soap::wsdl::get_style_parser_expr -argpart 1 C] + + # decl published list + set published [list] + + # duplicate procs as they're duplicated in the WSDL + # database - this will ensure + # every entry in the database is tested. ??? weak + + # decl dups + set dups [list] + + # scan + foreach proc $procs { + + # trim proc name + set short [namespace tail $proc] + + # decl counter + set count 0 + + # get hits in db + foreach binding $bindings { + + # compare + if [string equal $binding $short] { + + # incr counter + incr count + + # test for more than 1 + if { $count > 1 } { + + # add dup + lappend dups $proc + } + } + } + } + + # update proc list with duplicated db method entries + foreach dup $dups { + # add to proc list + lappend procs $dup + } + + # loop through source procs + foreach proc $procs { + + # trim proc name + set short [namespace tail $proc] + + # decl found + set found {} + + # decl diff var + set diff {} + + # get args for source proc (unpublished?) + set src_idl [soap::get_source_idl $proc]; #[info args $proc] + + # decl uargs (unpublished) + set uargs {} + + # invoke regexp to get args + if [regexp $method_expr $src_idl {} type src_meth argz] { + + # loop through args + foreach arg [split $argz ,] { + + # split + if [regexp $arg_expr $arg {} type name] { + + # add to list + lappend uargs $name + } + } + } else { + # store for check below + set src_meth $short + } + + # search published + foreach binding $bindings idl $idls { + + # try + if [catch { + + # test for case sensitive match + if [string equal $short $binding] { + + # decl pargs + set pargs [list] + + # invoke regexp to get args + if [regexp $method_expr $idl {} type method argz] { + + # loop through args + foreach arg [split $argz ,] { + + # split + if [regexp $arg_expr $arg {} type name] { + + # add to list + lappend pargs $name + } + } + + # park idl method name into found - used below + #set found $meth + } else { + # egats + continue + } + + # set found indicator + set found $method + + # compare unpublished args against published args + + # compare + if { [llength $uargs] != [llength $pargs] } { + + # note difference + set diff [list $uargs $pargs] + + } else { + + # compare arg names + foreach u $uargs p $pargs { + + # compare + if ![string equal -nocase $u $p] { + + # note difference + set diff [list $uargs $pargs] + + # enough to note diff + break + } + } + } + + # add to published list + lappend published $binding + + # get idx of binding + set idx [lsearch $bindings $binding] + + # remove from db lists + set bindings [lreplace $bindings $idx $idx] + set idls [lreplace $idls $idx $idx] + set methods [lreplace $methods $idx $idx] + } + } msg] { + + # show error for diff + set diff "err $msg" + } + + # test found + if { $found != {} } { + # stop scanning bindings for match - we found it + break + } + } + + # found ? + if { $found != {} } { + + # upper case found + set ufound [string toupper $found] + + # check for duplicate + if { [lsearch $history $ufound] >= 0 } { + # mark as duplicate + set diffs($found) [list DUPL $uargs $pargs] + } else { + # differences ? + if { $diff != {} } { + # append to results list + set diffs($found) [list ARGS $uargs $pargs] + } elseif [soap::server::lib::true $same] { + # append procs that are identical - 'same' flag set + set diffs($found) [list SAME $uargs $pargs] + } + + # add to history + lappend history $ufound + } + } else { + + # upper case + set found [string toupper $src_meth] + + # use full proc name to avoid potential clash + # with any db methods of same name + + # check for duplicate + if { [lsearch $history $found] >= 0 } { + # mark as duplicate + set diffs($proc) [list DUPL $uargs {}] + } else { + # append missing - modify array key to avoid + # clash with db method of same name + set diffs($proc) [list UPUB $uargs {}] + + # add to history + lappend history $found + } + } + } + + # add remaining bindings + foreach binding $bindings idl $idls { + + # invoke regexp to get args + if [regexp $method_expr $idl {} type method argz] { + + # decl pargs + set pargs [list] + + # loop through args + foreach arg [split $argz ,] { + # split + if [regexp $arg_expr $arg {} type name] { + # add to list + lappend pargs $name + } + } + + # append missing + set diffs($method) [list ORPH {} $pargs] + + } else { + + # append error + set diffs($binding) [list ERR {} {}] + } + } + + #return differences + return [array get diffs] +} + + +ad_proc -private soap::namespace_check { + namespace_id +} { + @param namespace_id +} { + # exec db + set exists [db_string namespace_exists {} -default 0] + + # test result + if { $exists == 0 || [string is integer $exists] != 1 } { + # failed, throw + soap::fault::raise "invalid namespace id: $namespace_id" + } + # valid +} \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-server-lib-procs-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-server-lib-procs-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-server-lib-procs-postgresql.xql 17 Oct 2004 05:51:53 -0000 1.1 @@ -0,0 +1,94 @@ + + + + postgresql7.1 + + + + select path from sg_libraries; + + + + + + select sg_method__new( + :namespace_id, + :method, + :idl, + :idl_style, + :proc, + :notes, + now(), + :user_id, + :peeraddr, + :package_id + ); + + + + + + select sg_namespace__new ( + :service, + :uri, + :notes, + now(), + :user_id, + :peeraddr, + :package_id + ) from dual; + + + + + + select sg_namespace__update( + :namespace_id, + :service, + :uri, + :notes, + ) from dual; + + + + + + select service, uri, notes + from sg_namespaces + where namespace_id = :nid + + + + + + + + + + + + select sg_library__new(:path) from dual + + + + + + select path + from sg_libraries + where library_id = :library_id + + + + + + select 0 + sg_library__delete(:library_id) + + + + + + select 0 + sg_library__update(:library_id,:path) + + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-server-lib-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-server-lib-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-server-lib-procs.tcl 17 Oct 2004 05:51:53 -0000 1.1 @@ -0,0 +1,624 @@ +ad_library { + + SOAP API for registering and handling TCL services located in the + library directory. + + @author William Byrne (WilliamB@ByrneLitho.com) + @author Nick Carroll (ncarroll@ee.usyd.edu.au) +} + + +namespace eval soap::server::lib {} + + +ad_proc -public soap::server::lib::library_new { + path +} { + @param path +} { + db_exec_plsql library_new {} +} + + +ad_proc -public soap::server::lib::library_update { + library_id + path +} { + @param library_id + @param path +} { + db_exec_plsql update_library {} +} + +ad_proc -public soap::server::lib::library_delete { + library_id +} { + @param library_id +} { + db_exec_plsql delete_library {} +} + + +ad_proc -public soap::server::lib::library_get_path { + library_id +} { + @param library_id +} { + set path [db_string select_path {} -default {} ] + + # return + return $path +} + + +ad_proc -private soap::server::lib::is_library_valid { + library +} { + @param library +} { + + # get root without tail / + set root [file join [acs_root_dir]] + + # test for directory + if [file isdirectory [file join $root $library]] { + # append wildcard + set library [file join $library *.tcl] + } + + # scan glob list + foreach f [glob -nocomplain -directory $root $library] { + # verify extension + if ![string equal -nocase [file extension $f] {.tcl}] { + # skip it + continue + } + # yup + return 1 + } + # clean + return 0 +} + +ad_proc -private soap::server::lib::is_library_dirty { + library +} { + @author William Byrne +} { + # get root without trailing / + set root [file join [acs_root_dir]] + + # get len + 1 for eventual / + set len [expr [string length $root] + 1] + + # test for directory + if [file isdirectory [file join $root $library]] { + # append wildcard + set library [file join $library *.tcl] + } + + # scan glob list + foreach f [glob -nocomplain -directory $root $library] { + # verify extension + if ![string equal -nocase [file extension $f] {.tcl}] { + # skip it + continue + } + + # get mtime + set mtime [file mtime $f] + + # get short + set short [string range $f $len end] + + # check to see if registered in loader + if ![nsv_exists apm_reload_watch $short] { + # remove from mtime + catch { nsv_unset apm_library_mtime $short } + } + + # get property without root + set cached [soap::get -set apm_library_mtime $short] + + # test + if { $cached == {} || $mtime != $cached } { + # dirty + return 1 + } + } + # clean + return 0 +} + + +ad_proc -private soap::server::lib::library_get_paths { +} { + @author William Byrne +} { + # init + set paths [list] + + # loop through libraries + db_foreach select_lib_paths {} { + # append name + lappend paths $path + } + + # return names + return $paths +} + + +ad_proc -public soap::server::lib::update_libraries { + {-stop 0} + {libraries [list]} +} { + @author William Byrne +} { + # get root without trailing / + set root [file join [acs_root_dir]] + + # get len + 1 for eventual / + set len [expr [string length $root] + 1] + + # loop through libraries + foreach lib $libraries { + + # test for directory + if [file isdirectory [file join $root $lib]] { + # append wildcard + set lib [file join $lib *.tcl] + } elseif ![string equal -nocase [file extension $lib] {.tcl}] { + # skip it + continue + } + + # scan glob list + foreach f [glob -nocomplain -directory $root $lib] { + # add to watch without root + soap::server::lib::watch -stop $stop [string range $f $len end] + } + } + # return something + return 1 +} + + +ad_proc -private soap::server::lib::true { + value +} { + @author William Byrne +} { + # handle ints > 1 || < 0 + if [string is integer $value] { + # eval + return [expr $value != 0 ? 1 : 0] + } + + # empty value is false + return [expr [string length $value] > 0 && [string is true $value] ? 1 : 0] +} + + +ad_proc -public soap::server::lib::watch { + {-stop 0} + file +} { + @author William Byrne +} { + # setup result + set result 1 + + # test for stop + if [soap::server::lib::true $stop] { + # safe + if [catch { + # stop watch + nsv_unset apm_reload_watch $file + }] { + # egats + set result 0 + } + # safe + catch { + # remove cache + nsv_unset apm_library_mtime $file + } + + } else { + # add + apm_file_watch $file + } + + # return status + return $result +} + + +ad_proc -public soap::server::lib::boot_libraries { +} { + @author William Byrne +} { + # get paths + set paths [soap::server::lib::library_get_paths] + + # send to update + foreach lib $paths { + soap::server::lib::update_libraries $lib + } + + # return something + return 1 +} + + +ad_proc -private soap::server::lib::get_library_doc { + service +} { + @param service +} { + # get a command from namespace + set procs [info commands [format "::sg::%s" $service]] + + # decl source path + set path {} + + # any ? + if [llength $procs] { + # get first one + set proc [lindex $procs 0] + + # safe + catch { + # get the documentenation array for the method + array set doc_elements [nsv_get api_proc_doc \ + [format "::sg::%s::%s" $service $proc]] + + # get script path + set path $doc_elements(script) + } + } + + # check path + if { $path == {} } { + + # try lib directory + set path "packages/soap-gateway/lib/[string tolower $service]-procs.tcl" + } + + # decl result + set result {} + + # try to get doc info from file + catch { + # get source file docs - force lower case convention + array set doc_elements [nsv_get api_library_doc $path] + + # update and remove curlies + set result [join $doc_elements(main)] + } + + # return whatever we got + return $result +} + + +ad_proc -public soap::server::lib::method_new { + namespace_id + method + idl + idl_style + proc + notes + user_id + peeraddr + package_id +} { + @param namespace_id + @param method + @param idl + @param idl_style + @param proc + @param notes + @param user_id + @param peeraddr + @param package_id +} { + # create new - + db_exec_plsql method_new {} +} + + +ad_proc -public soap::server::lib::namespace_new { + service + uri + notes + user_id + peeraddr + package_id +} { + @param service + @param uri + @param notes + @param user_id + @param peeraddr + @param package_id +} { + # db new + db_exec_plsql namespace_new {} +} + + +ad_proc -public soap::server::lib::namespace_update { + namespace_id + service + uri + notes +} { + @param namespace_id + @param service + @param uri + @param notes +} { + db_exec_plsql namespace_update {} +} + + +ad_proc -private soap::server::lib::get_proc_doc { + proc +} { + @param proc +} { + # decl result + set result {} + + # safe + catch { + + # remove sg namespace + if { [string equal -length 6 ::sg:: $proc] } { + # trim :: + set proc [string range $proc 2 end] + } + + # get doc set for procedure + array set doc_elements [nsv_get api_proc_doc $proc] + + # get main documentation and remove curlies + set result [join $doc_elements(main)] + } + + # return procedure doc + return $result +} + + +ad_proc -private soap::server::lib::idl_to_xsd { + style + idl +} { + @param style + @param idl +} { + # verify style + if { [string compare -nocase $style "C"] != 0 } { + + # not yet supported + soap::fault::unsupported "Unsupported IDL style: $style\n Use 'C'" + + } + + # set up regexp expression for "C" style function + set expr [soap::wsdl::get_style_parser_expr C] + + # invoke regexp + regexp $expr $idl {} type method argz + + # map type + set xtype [soap::wsdl::map_ctype_to_xtype $type] + + # verify + if { [llength $xtype] > 1 } { + + # not yet supported + soap::fault::unsupported "cannot spec non simple types: $type" + + } + + # setup arg list + set xargs [list] + + # get arg parser expr + set expr [soap::wsdl::get_style_parser_expr -argpart 1 C] + + # loop through args + foreach a [split $argz ,] { + + # split arg type from its name + if ![regexp $expr $a {} typ nam] { + + # format problem + error "unexpected argument format: $a" + + } + + # add arg to param order var + lappend order $nam + + # map type + set xtype2 [soap::wsdl::map_ctype_to_xtype $typ] + + # get component count + set cnt [llength $xtype2] + + # test for simple + if { $cnt == 1 } { + + # append to arg list + lappend xargs [list [lindex $xtype2 0] $nam] + + } else { + + # not yet supported + soap::fault::unsupported "cannot spec non simple types: $a, $xtype2" + } + } + + # build return + return [list $xtype $method $xargs] +} + + +ad_proc -public soap::server::lib::method_update { + method_id + method + idl + idl_style + proc + notes +} { + @param method_id + @param method + @param idl + @param idl_style + @param proc + @param notes +} { + # update existing + db_exec_plsql method_update {} +} + + +ad_proc -private soap::server::lib::import_service { + {-force 0} + {-proc {}} + service +} { + @param service +} { + # set connection vars + set user_id [ad_conn user_id] + set peeraddr {} + set package_id [ad_conn package_id] + + # verify workspace namespace + set nid [soap::server::namespace_get_id $service] + + # test + if { $nid == -1 } { + + # get doc + set notes [soap::server::lib::get_library_doc $service] + + # create + soap::server::lib::namespace_new \ + $service "http://$service.openacs.org/methods" \ + $notes $user_id $peeraddr $package_id + + # clear + unset notes + + # get id + set nid [soap::server::namespace_get_id $service] + + } elseif { $force } { + + # query for namespace attributes + db_1row namespace_select {} + + # get doc + set notes [soap::server::lib::get_library_doc $service] + + # update with new notes + soap::server::lib::namespace_update $nid $service $uri $notes + } + + # get public procs for namespace + + # set method parameters - idl style + set idl_style {C} + + # build procs list + set procs [soap::get_source_procs $service] + + # test for optional proc arg + if { $proc != {} } { + + # test for ns qualifier ??? (weak) + if ![string equal -length 6 $proc {::sg::}] { + # fix up + set proc [format "::sg::%s::%s" $service $proc] + } + + # contained in list + if { [lsearch -exact $procs $proc] >= 0 } { + # use + set procs [list $proc] + } else { + # clear, not found + set procs [list] + } + } + + # loop + foreach proc $procs { + # get idl + set idl [soap::get_source_idl $proc] + + # get notes + set note [soap::server::lib::get_proc_doc $proc] + + # try + if [catch { + # decompose IDL + set xsd [soap::server::lib::idl_to_xsd $idl_style $idl] + } msg] { + # report + soap::fault::raise "Error importing: $proc, idl: $idl\n$msg" + } + + # get method name from idl + set method [lindex $xsd 1] + + # remove namespace + set proc [namespace tail $proc] + + # verify workspace method + set mid [soap::wsdl::method_get_id $nid $method] + + # test + if { $mid == -1 } { + # create + soap::server::lib::method_new $nid $method $idl $idl_style \ + $proc $note $user_id $peeraddr $nid + + # test for 'login' + if [string equal -nocase $method "LOGIN"] { + # get method id + set mid [soap::wsdl::method_get_id $nid $method] + + # verify + soap::fault::assert {$mid != -1} "Error retrieving 'login' method id: $method => $mid" + + # get public + set public_id [acs_magic_object the_public] + + # get invoke symbol + set invoke [soap::server::get_invoke_permission_moniker] + + # grant invoke permission to public + permission::grant -party_id $public_id -object_id $mid -privilege $invoke + + # verify + set ok [permission::permission_p -party_id $public_id -object_id $mid -privilege $invoke] + soap::fault::assert $ok "Error granting '$invoke' permission to public" + } + } elseif { $force } { + # update + error "soap::server::lib::method_update $mid $method $idl $idl_style $proc $note" + } + } + + # return namespace id + return $nid +} \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-server-procs-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-server-procs-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-server-procs-postgresql.xql 17 Oct 2004 05:51:53 -0000 1.1 @@ -0,0 +1,32 @@ + + + + postgresql7.1 + + + + select sg_namespace__get_id(:service) from dual + + + + + + select sg_namespace__get_id(:service) from dual + + + + + + select method_id || ' ' || proc + from sg_methods + where namespace_id = :namespace_id and + lower(method) = lower(:method) + + + + + + select * from sg_invoke_moniker + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-server-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-server-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-server-procs.tcl 17 Oct 2004 05:51:54 -0000 1.1 @@ -0,0 +1,425 @@ +ad_library { + Tcl API for a SOAP Server. + + Based on William Byrne's soap-gateway implementation. + + @author William Byrne (WilliamB@ByrneLitho.com) + @author Nick Carroll (ncarroll@ee.usyd.edu.au) + @creation-date 2004-09-24 + @cvs-id $Id: soap-server-procs.tcl,v 1.1 2004/10/17 05:51:54 ncarroll Exp $ +} + +namespace eval soap::server {} + +ad_proc -public soap::server::get_version_namespace { + ver +} { + Returns the namespace for the specified SOAP version. + + @param ver A SOAP version, eg 1.1 or 1.2. + @return Returns the namespace associated with the specified + version of SOAP. +} { + + switch $ver { + 1.1 { + # Namespace for SOAP 1.1 + return [parameter::get -parameter "SOAP_NS_1_1"] + } + 1.2 { + # Namespace for SOAP 1.2 + return [parameter::get -parameter "SOAP_NS_1_2"] + } + } + + # return 1.1 as safety + return [parameter::get -parameter "SOAP_NS_1_1"] +} + +ad_proc -public soap::server::get_version_encoding { + ver +} { + Returns the encoding for the specified SOAP version. + + @param ver A SOAP version, eg 1.1 or 1.2. + @return Returns the encoding associated with the specified + version of SOAP. +} { + switch $ver { + 1.1 { + return [parameter::get -parameter "SOAP_ENC_1_1"] + } + 1.2 { + return [parameter::get -parameter "SOAP_ENC_1_2"] + } + } + + # return 1.1 as safety + return [parameter::get -parameter "SOAP_ENC_1_1"] +} + +ad_proc -public soap::server::get_url_params { +} { + @author William Byrne +} { + # try to get from target url + set request [ns_conn request] + + # search for ? + set offset [string first "?" $request] + + # test + if { $offset >= 0 } { + + # fixup offset + incr offset + + # find first space after query + set last [string first " " $request $offset] + + # fixup + if { $last < 0 } { + set last end + } else { + incr last -1 + } + + # get query + set query [string range $request $offset $last] + + } else { + # clear + set query {} + } + # return params as ns_set + return [ns_parsequery $query] +} + +ad_proc -public soap::server::get_url_param { + param +} { + @author William Byrne +} { + # get params + set params [soap::server::get_url_params] + + # return requested + return [ns_set get $params $param] +} + +ad_proc -public soap::server::has_permission { + {-user_id {}} + object_id + privilege +} { + @param object_id + @param privilege +} { + # test user + if { $user_id == {} } { + # set to current user + set user_id [ad_conn user_id] + } + + # return permission cache + return [permission::permission_p -party_id $user_id \ + -object_id $object_id -privilege $privilege] +} + +ad_proc -public soap::server::require_permission { + object_id + privilege +} { + @param object_id + @param privilege +} { + # check permission cache + if { ![soap::server::has_permission $object_id $privilege] } { + # deny + return [soap::fault::generate_error "Unauthorized: Access Denied"] + } +} + +ad_proc -public soap::server::invoke { + env +} { + Take the SOAP request and invoke the method on the server. + + @param env The SOAP envelope sent from the client. + @return result wrapped in a SOAP response envelope and returned + to the client. +} { + + # Invoke in safe block + if {[catch {set result [soap::server::do_invoke $env]} err_msg]} { + # build fault + set result [soap::fault::generate_fault $err_msg] + } + + # return envelope + return $result +} + + +ad_proc -private soap::server::do_invoke { + env +} { + Parses the specified SOAP envelope for methods, and invokes these + methods with the supplied arguments. The results (if any) are + returned to the invoking client as a SOAP response. + + @param env The SOAP envelope to parse for methods to invoke. + @return Returns a SOAP response for the invoking client. +} { + # force to v1.1 + set ver 1.1 + + # set encoding style + set encoding [soap::server::get_version_encoding $ver] + + # set envelope version + set version [soap::server::get_version_namespace $ver] + + # parse incoming soap envelope + set doc [dom parse $env] + + # LOG SOAP Request + ns_log Notice "\nSOAP Request:\n[$doc asXML]" + + # get doc root + set root [$doc documentElement] + + # get child nodes of Envelope + set children [$root childNodes] + + # decl method for response + set method {} + set result {} + + # Brute force envelope search is performed in place of + # preferred XPath search. I ran into issues that were complicated + # by the fact that XPath was not available on a + # baseline installation. The goal is to demonstrate SOAP interop + # and not necessarily write the ideal implementation. Furthermore, + # if the envelope exists within XML, it + # should be found quickly. + + # decl mustUnderstand list + set misunderstood {} + + set header [$root selectNodes /SOAP-ENV:Envelope/SOAP-ENV:Header] + + # test for header + if ![empty_string_p $header] { + + # get requisites + set reqs [$header childNodes] + + # loop + foreach r $reqs { + + # look for must understand + set mu [$r getAttribute mustUnderstand] + + # test + if { $mu == "1" || [string equal -nocase $mu true] } { + + # don't understand anything other than + # basics right now + # add to list - should be qnames with namespaces?? + lappend misunderstood [list $r {}] + } + } + } + + set body [$root selectNodes /SOAP-ENV:Envelope/SOAP-ENV:Body] + + # test for body + if ![empty_string_p $body] { + + # before proceeding, make sure "misunderstood" var is clear + if { $misunderstood != {} } { + + # return misunderstood fault + return [soap::fault::generate_misunderstood $misunderstood] + + } + + # get methods + set methods [$body childNodes] + + # loop + foreach m $methods { + + # get node type + set type [$m nodeType] + + # test for element - skip cdata (axis) + if { [string equal -nocase $type "cdata_section"] } { + # skip + continue + } + + # get method namespace + set service {}; + + # verify + if { $service == {} } { + # parse connection url and see if it's there + set service [soap::server::get_url_param service] + } + + # get service/namespace id + set nid [soap::server::namespace_get_id $service] + + # verify + if { $nid < 0 } { + # not found + return [soap::fault::generate_error "Error: $namespace not found"] + } + + # get method + set method [$m nodeName] + + # authenticate + + # get method id and proc + set id_proc [soap::server::method_get_id_and_proc $nid $method] + + # get id + set mid [lindex $id_proc 0] + + # get proc + set proc [lindex $id_proc 1] + + # verify + if { $mid < 0 } { + # throw + set error_msg [format "Invalid service method: '%s:%s'" \ + $service $method] + return [soap::fault::generate_error "Error: $error_msg"] + } + +### Get this working! + # try authenticating to method +#### soap::server::require_permission $mid [soap::server::get_invoke_permission_moniker] + + # build namespace into expr + set expr "sg::" + + # append namespace and proc + append expr $service :: $proc + + # get args + set args [$m childNodes] + + # loop + foreach a $args { + # get node type + set text_node [$a firstChild] + lappend expr [$text_node nodeValue] + } + + # invoke - error will be caught by + # caller and returned as fault + set result [eval $expr] + + # done + break + } + } + + return [soap::server::response $version $encoding $method $result] +} + +ad_proc -private soap::server::response { + version + encoding + method + result +} { + Constructs a SOAP response based on the specified result and method. + + @param version The version of SOAP. + @param encoding The encoding used for the version of SOAP specified. + @param method Method name. + @param result Result to return to the SOAP client. + @return Returns a SOAP response envelope. +} { + # construct xml doc object + set doc [dom createDocument env:Envelope] + + # create root node: "env:Envelope" + set env [$doc documentElement] + + # define namespace atts into node + $env setAttribute xmlns:env $version + + # define encoding style atts into node + $env setAttribute env:encodingStyle $encoding + + # create SOAP header - "env:Envelope/env:Header" + set header [$env appendChild [$doc createElement env:Header]] + + # create SOAP body - "env:Envelope/env:Body" + set body [$env appendChild [$doc createElement env:Body]] + + # create method node - "env:Envelope/env:Body/?method?" + set method_node [$body appendChild [$doc createElement [format "m:%s%s" $method Response]]] + + # define namespace atts into node + $method_node setAttribute xmlns:m {http://namespace}; # need real namespace + + # create args node - "env:Envelope/env:Body/?method?/?arg?" + set result_node [$method_node appendChild [$doc createElement Result]] + set args [$result_node appendChild [$doc createTextNode $result]] + + # LOG SOAP Response + ns_log Notice "\nSOAP Response:\n[$doc asXML]" + + # render xml into result string + return [$doc asXML] +} + +ad_proc -public soap::server::namespace_get_id { + service +} { + @param service The service used to query the namespace id for. + @return Returns the namespace id for the given service. +} { + return [db_string namespace_id {} -default -1 ] +} + +ad_proc -public soap::server::method_get_id_and_proc { + namespace_id + method +} { + @param namespace_id + @param method + @return Returns the method ID and proc name for the given namespace ID. +} { + return [db_string method_id_proc {} -default {-1 {}}] +} + +ad_proc -private soap::server::get_invoke_permission_moniker { +} { + @author William Byrne +} { + # short cut + return "invoke" + + # eval global within sg namespace + namespace eval sg { + # decl moniker + variable invoke_moniker + + # test for moniker + if { ![info exists invoke_moniker] } { + # get it + set invoke_moniker [db_string select_moniker {}] + } + + # return it + return $invoke_moniker + } +} \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-wsdl-procs-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-wsdl-procs-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-wsdl-procs-postgresql.xql 17 Oct 2004 05:51:54 -0000 1.1 @@ -0,0 +1,48 @@ + + + + postgresql7.1 + + + + select idl + from sg_methods + where namespace_id = :namespace_id + order by method_id + + + + + + select notes + from sg_methods + where method_id = :method_id + + + + + + select method_id + from sg_methods + where namespace_id = :namespace_id and + lower(method) = lower(:method) + + + + + + select method_id + from sg_methods + where namespace_id = :namespace_id and proc = :method + + + + + + select notes + from sg_namespaces + where namespace_id = :namespace_id + + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/tcl/soap-wsdl-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/tcl/soap-wsdl-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/tcl/soap-wsdl-procs.tcl 17 Oct 2004 05:51:54 -0000 1.1 @@ -0,0 +1,639 @@ +ad_library { + Tcl API for generating WSDLs. + + Based on William Byrne's soap-gateway implementation. + + @author William Byrne (WilliamB@ByrneLitho.com) + @author Nick Carroll (ncarroll@ee.usyd.edu.au) + @creation-date 2004-09-24 + @cvs-id $Id: soap-wsdl-procs.tcl,v 1.1 2004/10/17 05:51:54 ncarroll Exp $ +} + + +namespace eval soap::wsdl {} + + +ad_proc -private soap::wsdl::build_wsdl_url { + service +} { + @param service +} { + + # normal + set location [ns_conn location] + + # build wsdl url + set wsdl [file join [ad_conn object_url] wsdl] + + # return format + return [format "%s%s?service=%s" $location $wsdl $service] +} + + +ad_proc -private soap::wsdl::method_get_idls { + namespace_id +} { + @author William Byrne +} { + # init + set methods [list] + + # loop through methods belonging to namespace ??? XQL + db_foreach select_idls {} { + # append method idl + lappend methods $idl + } + + # return methods + return $methods +} + + +ad_proc -private soap::wsdl::get_style_parser_expr { + {-argpart 0} + {style "C"} +} { + @author William Byrne +} { + # switch + switch $style { + C { + # test for arg expression + if $argpart { + + #return {(.+)(\w+) *$} + return {(\w+\W+)(\w+)} + + } else { + + return {^ *([^ ]+) +([a-zA-Z][a-zA-Z0-9_]*) *\(([^)]*)} + } + } + default { + # throw + soap::fault::raise "Unsupported IDL parse style: $style" + } + } +} + + +ad_proc -public soap::wsdl::method_get_notes { + method_id +} { + @author William Byrne +} { + return [db_string select_notes {} -default -1 ] +} + + +ad_proc -public soap::wsdl::method_get_id { + {-proc 0} + namespace_id + method +} { + @author William Byrne +} { + # test for 'proc' clause + if [soap::server::lib::true $proc] { + set id [db_string method_get_id_with_proc {} -default -1 ] + } else { + set id [db_string method_get_id {} -default -1 ] + } + + # return + return $id +} + + +ad_proc -private soap::wsdl::build_namespace_uri { + service +} { + @author William Byrne +} { + # basic uri + return "http://$service.openacs.org/message/" +} + + +ad_proc -public soap::wsdl::namespace_get_notes { + namespace_id +} { + @param namespace_id +} { + return [db_string select_notes {} -default -1 ] +} + + +ad_proc -private soap::wsdl::map_ctype_to_xtype { + type +} { + @param type +} { + + # strip whitespace + regsub -all { } $type {} typ + + # map type + switch $typ { + + char - + wchar_t { + # simple character type + return [list xsd:string] + } + + int - + long { + # simpl int + return [list xsd:int] + } + + float - + double { + # simple floating point + return [list xsd:double] + } + + __int64 { + # simple long long + return [list xsd:long] + } + + char[] - + wchar_t[] - + string - + wstring { + # string (keep simple) + return [list xsd:string] + } + + int[] - + long[] { + # array of ints + return [list xsd:int *] + } + + float[] - + double[] { + # array of floating point + return [list xsd:double *] + } + + __int64[] { + # array long long + return [list xsd:long *] + } + + void { + # void type + return [list] + } + } + + # not supported + soap::fault::unsupported "unable to map $type to xml type - '$type' refined to '$typ'" +} + + +ad_proc -private soap::wsdl::build_endpoint { + service + {trace {}} +} { + @param service + @param trace +} { + # test for trace + if { $trace != {} } { + # use trace info specified in call + set location $trace + } else { + # normal + set location [ns_conn location] + } + + # build action url + set action [file join [ad_conn object_url] action] + + # return format + return [format "%s%s?service=%s" $location $action $service] +} + + +ad_proc -private soap::wsdl::do_generate_wsdl { + namespace + documentation + oneway + trace +} { + @author William Byrne +} { + + # get namespace id + set nid [soap::server::namespace_get_id $namespace] + + # verify + if { $nid < 0 } { + + # not found + soap::fault::raise "service '$namespace' not found" 404 + + } + + # fixup documentation boolean + set documentation [soap::server::lib::true $documentation] + + # authenticate + # ??? soap::server::require_permission $nid read + + # force to v1.1 + set ver 1.1 + + # set encoding style + set encoding [soap::server::get_version_encoding $ver] + + # get methods for namespace + set funcs [soap::wsdl::method_get_idls $nid] + + # decl methods + set methods [list] + + # set up regexp expression for "C" style function + set expr [soap::wsdl::get_style_parser_expr C] + #set expr {^ *([^ ]+) +([a-zA-Z0-9_]+) *\(([^)]*)} + + # loop through functions + foreach func $funcs { + + # invoke regexp + regexp $expr $func {} type method argz + + # add func to methods list0 + lappend methods $method + + # store funcs + set method_funcs($method) $argz + + # store func type + set method_types($method) $type + + # store args + set method_args($method) [split $argz ,] + + # get notes + if $documentation { + set method_notes($method) [soap::wsdl::method_get_notes \ + [soap::wsdl::method_get_id $nid $method]] + } + } + + # construct wsdl doc object + set doc [dom createDocument definitions] + + # create root WSDL node: "definitions" + set defs [$doc documentElement] + + # build namespace uri for methods + set nsuri [soap::wsdl::build_namespace_uri $namespace] + + # define namespace atts into "definitions" node + $defs setAttribute name $namespace + $defs setAttribute targetNamespace "http://$namespace.openacs.org/wsdl/" + $defs setAttribute xmlns:wsdlns "http://$namespace.openacs.org/wsdl/" + $defs setAttribute xmlns:typens "http://$namespace.openacs.org/type" + $defs setAttribute xmlns:soap "http://schemas.xmlsoap.org/wsdl/soap/" + $defs setAttribute xmlns:xsd "http://www.w3.org/2001/XMLSchema" + $defs setAttribute xmlns "http://schemas.xmlsoap.org/wsdl/" + + # add documentation + if $documentation { + # get notes for namespace + set notes [soap::wsdl::namespace_get_notes $nid] + + # create child "definitions/documentation" node (allow empty notes) + set doc_node [$defs appendChild [$doc createElement documentation]] + set docu [$doc_node appendChild [$doc createTextNode $notes]] + } + + # create child "definitions/types" node + set types [$defs appendChild [$doc createElement types]] + + # create child "definitions/types/schema" node + set schema [$types appendChild [$doc createElement schema]] + + # define namespace atts into "definitions/types/schema" node + $schema setAttribute targetNamespace "http://$namespace.openacs.org/type" + $schema setAttribute xmlns "http://www.w3.org/2001/XMLSchema" + $schema setAttribute xmlns:enc $encoding + $schema setAttribute xmlns:wsdl "http://schemas.xmlsoap.org/wsdl/" + $schema setAttribute elementFormDefault "qualified" + + # loop through decomposed methods + foreach m $methods { + + # get args + set argz $method_args($m) + + # create "definitions/message" node + set message [$defs appendChild [$doc createElement message]] + + # add name attr + $message setAttribute name "$namespace.$m" + + # add documentation + if $documentation { + + # create child "definitions/message/documentation" node + # (allow empty notes) + set doc_node [$message appendChild [$doc createElement documentation]] + set docu [$doc_node appendChild [$doc createTextNode $method_notes($m)]] + } + + # decl param order arg + set order "" + + # get arg part parser expr + set expr [soap::wsdl::get_style_parser_expr -argpart 1 C] + + # loop through args + foreach a $argz { + + # split arg type from its name + if ![regexp $expr $a {} typ nam] { + + # format problem + error "unexpected argument format: '$a' in '$argz', '$m', '$method_args($m)'" + + } + + # add arg to param order var + lappend order $nam + + # map type + set xtype [soap::wsdl::map_ctype_to_xtype $typ] + + # get component count + set cnt [llength $xtype] + + # test for simple + if { $cnt == 1 } { + + # create arg parts + set part [$message appendChild [$doc createElement part]] + + # add name attr + $part setAttribute name $nam + + # add type attr + $part setAttribute type [lindex $xtype 0] + + } else { + + # not yet supported + soap::fault::unsupported "cannot spec non simple types: $a, $xtype" + } + } + + # reset method_args to hold param order + set method_args($m) $order + + # build return message + set typ $method_types($m) + + # map type + set xtype [soap::wsdl::map_ctype_to_xtype $typ] + + # get component count + set cnt [llength $xtype] + + # test for void + if { $cnt != 0} { + + # set boolean into method type for Respond in portType wsdl node + set method_types($m) 1 + + # create response message + set message [$defs appendChild [$doc createElement message]] + + # add name attr + $message setAttribute name [format "$namespace.$m%s" Response] + + # test for simple + if { $cnt == 1 } { + + # create arg parts + set part [$message appendChild [$doc createElement part]] + + # add name attr + $part setAttribute name Result + + # add type attr + $part setAttribute type [lindex $xtype 0] + + } else { + # not yet supported + soap::fault::unsupported "cannot spec non simple types: $typ" + } + + } elseif { $oneway } { + # set false boolean into method type eliminating + # Respond in portType wsdl node + set method_types($m) 0 + } else { + # set true boolean into method type forcing + # void Respond in portType wsdl node + set method_types($m) 1 + + # create response message + set message [$defs appendChild [$doc createElement message]] + + # add name attr + $message setAttribute name [format "$namespace.$m%s" Response] + + # force string result type + if { 1 } { + + # create arg parts + set part [$message appendChild [$doc createElement part]] + + # add name attr + $part setAttribute name Result + + # add type attr + $part setAttribute type {xsd:string} + } + } + } + + # create portType "definitions/portType" node + set portType [$defs appendChild [$doc createElement portType]] + + # set its name + $portType setAttribute name [format "%s%s" $namespace SoapPort] + + # create operations for each function + foreach m $methods { + + # create new operation + set operation [$portType appendChild [$doc createElement operation]] + + # set its name + $operation setAttribute name $m + + # set parameter order + $operation setAttribute parameterOrder $method_args($m) + + # create input op + set input [$operation appendChild [$doc createElement input]] + + # bind to message node + $input setAttribute message [format "wsdlns:%s.%s" $namespace $m] + + # test for non void function (false if void) + if $method_types($m) { + + # create output op + set output [$operation appendChild [$doc createElement output]] + + # bind to message node + $output setAttribute message [format "wsdlns:%s.%s%s" $namespace $m Response] + } + } + + # setup RPC bindings, encodings, and namespaces + + # create binding node - "definitions/binding" + set binding [$defs appendChild [$doc createElement binding]] + + # set its name + $binding setAttribute name [format "%s%s" $namespace SoapBinding] + + # set its type + $binding setAttribute type [format "wsdlns:%s%s" $namespace SoapPort] + + # create child soap binding node + set soap_binding [$binding appendChild [$doc createElement soap:binding]] + + # set rpc style + $soap_binding setAttribute style rpc + + # set transport + $soap_binding setAttribute transport {http://schemas.xmlsoap.org/soap/http} + + # loop through methods + foreach m $methods { + + # create input child - "definitions/binding/operation" + set operation [$binding appendChild [$doc createElement operation]] + + # set its name + $operation setAttribute name $m + + # create child soap operation node + # definitions/binding/operation/soap:operation + set soap_operation [$operation appendChild [$doc createElement soap:operation]] + + # set soap action + $soap_operation setAttribute soapAction [format "http://%s.openacs.org/action/%s.%s" $namespace $namespace $m] + + # create child input - "definitions/binding/operation/input" + set input [$operation appendChild [$doc createElement input]] + + # create child soap_body node + # definitions/binding/operation/input/soap:body + set soap_body [$input appendChild [$doc createElement soap:body]] + + # set 'use' attr + $soap_body setAttribute use encoded + + # set namespace + $soap_body setAttribute namespace $nsuri + + # set encoding + $soap_body setAttribute encodingStyle $encoding + + # test for output + if $method_types($m) { + + # create child output - "definitions/binding/operation/output" + set output [$operation appendChild [$doc createElement output]] + + # create child soap_body node + # definitions/binding/operation/output/soap:body + set soap_body [$output appendChild [$doc createElement soap:body]] + + # set 'use' attr + $soap_body setAttribute use encoded + + # set namespace + $soap_body setAttribute namespace "http://$namespace.openacs.org/message/" + + # set encoding + $soap_body setAttribute encodingStyle $encoding + } + } + + # create service + + # create service node - "definitions/service" + set service [$defs appendChild [$doc createElement service]] + + # set its name + $service setAttribute name $namespace + + # create child port - "definitions/service/port" + set port [$service appendChild [$doc createElement port]] + + # set its name + $port setAttribute name [format "%s%s" $namespace SoapPort] + + # set its binding + $port setAttribute binding [format "wsdlns:%s%s" $namespace SoapBinding] + + # create child address - "definitions/service/port/soap:address" + set soap_address [$port appendChild [$doc createElement soap:address]] + + # set its location + $soap_address setAttribute location [soap::wsdl::build_endpoint $namespace $trace] + + # render xml into string + return [$doc asXML] + +} + + +ad_proc -public soap::wsdl::generate_wsdl { + {-documentation 1} + namespace + {oneway 1} + {trace {}} +} { + @author William Byrne +} { + # fixup and set missing to true + if { $oneway == {} } { set oneway 1 } + + # try + if { [catch { + + # delegate to do_generate + set wsdl [soap::wsdl::do_generate_wsdl $namespace $documentation $oneway $trace] + + } msg] } { + + # get error code + global errorCode + set code $errorCode + + # normalize error code + if { ![string is integer $code] } { set code 500 } + + # error + global errorInfo + ns_returnerror $code "
$msg\n$errorInfo
" + + } else { + + # return wsdl + return $wsdl + } +} \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/action.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/action.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/action.tcl 17 Oct 2004 05:51:55 -0000 1.1 @@ -0,0 +1,78 @@ +# /packages/soap-gateway/www/action.tcl + +# page contract not included due to cost of parsing payload - (not necessary) + +# generate temp file name +set tmp [ns_tmpnam] + +# open it +set f [open $tmp w+] + +# perform file ops in safe block to ensure tmp file unlink +# (yes, this is a back asswards approach) +set err [catch { + + # dump payload to file - there's gotta be a better way to get the content + ns_conncptofp $f + + # get file size + set size [tell $f] + + # limit incoming envelope size to 1/4 meg + if { $size > 262144 || $size < 0 } { + + # throw it + error "payload too large" + + } + + # seek to beginning + seek $f 0 + + # read file contents into SOAP envelope var + set env [read $f $size] + +} msg] + +# test for error +if { $err != 0 } { + + # make em' wait + ns_sleep 5 + + # prep + set savedInfo {} + + # advise + global errorInfo + + # test + if { [info exists errorInfo] != 0 } { + + # preserve error info + set savedInfo $errorInfo + + } + + # release file + catch { close $f } + + # unlink file + ns_unlink $tmp + + # throw + error "$msg\nfile: $tmp" $savedInfo + +} else { + + # release file + catch { close $f } + + # unlink file + ns_unlink $tmp + + +} + +# invoke envelope using lib functions and return +ns_return 200 text/xml [soap::server::invoke $env] Index: openacs-4/packages/soap-gateway/www/debug.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/debug.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/debug.adp 17 Oct 2004 05:51:55 -0000 1.1 @@ -0,0 +1,4 @@ + + + +@result@ \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/debug.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/debug.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/debug.tcl 17 Oct 2004 05:51:55 -0000 1.1 @@ -0,0 +1,37 @@ +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: debug.tcl,v 1.1 2004/10/17 05:51:55 ncarroll Exp $ +} { + {expr {}} +} + +template::form create debug_form + +# build service input field +template::element create debug_form expr \ + -widget textarea \ + -datatype text \ + -label "expr" \ + -html { rows 8 cols 80 wrap off } \ + -value $expr + +# test for valid form +if [template::form is_valid debug_form] { + + if [catch { + set result [uplevel $expr] + } msg] { + set result $msg + } + +} else { + + set result {} + +} + +ad_return_template + + Index: openacs-4/packages/soap-gateway/www/index-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/index-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/index-postgresql.xql 17 Oct 2004 05:51:55 -0000 1.1 @@ -0,0 +1,11 @@ + + + + postgresql7.1 + + + + select namespace_id, service, uri, notes from sg_namespaces + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/index.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/index.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/index.adp 17 Oct 2004 05:51:55 -0000 1.1 @@ -0,0 +1,98 @@ + + + + + + + + + + + + + + + + + + + +
ServiceNotesWSDL
+ @namespaces.service@ + + @namespaces.notes;noquote@  + wsdl
+ + +

There are no namespaces

+ + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Service: + @namespaces.service@ +  
Endpoint: + @namespaces.endpoint@ +  
WSDL: + @namespaces.wsdl@ +  
 force response: + @namespaces.wsdl@ + &oneway=0 
 no documentation: + @namespaces.wsdl@ + &documentation=0 
 trace: + @namespaces.wsdl@ + &trace=http://localhost:8080 
URI + @namespaces.uri@ +  
SOAPActionN/A 
Notes: + @namespaces.notes;noquote@ (more) +  
+ + + + Index: openacs-4/packages/soap-gateway/www/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/index.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/index.tcl 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,61 @@ +# packages/soap-gateway/www/index.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: index.tcl,v 1.1 2004/10/17 05:51:56 ncarroll Exp $ +} { +} + +# clear title +set title {} + +# installed correctly +if [catch { + + soap::server::lib::true 1 + +}] { + + # report as installation error + error "Failure while calling soap-gateway function!\nDid you restart the server after installing soap-gateway package?\n\n" + +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# query namespaces +db_multirow -extend {endpoint edit delete wsdl} namespaces namespace_list {} { + set endpoint [soap::wsdl::build_endpoint $service] + set edit "edit-namespace?namespace_id=$namespace_id" + set delete "delete-namespace?namespace_id=$namespace_id" + set wsdl [soap::wsdl::build_wsdl_url $service] +} + +# create form +template::form create new_namespace_form + +# change action attribute for form - not documented +set new_namespace_form:properties(action) edit-namespace + +# create form +template::form create init_workspace_form + +# change action attribute for form - not documented +set init_workspace_form:properties(action) init-workspace + +# create form +template::form create init_interop_form + +# change action attribute for form - not documented +set init_interop_form:properties(action) init-interop + +# update caption +set caption "services" + +ad_return_template Index: openacs-4/packages/soap-gateway/www/master.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/master.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/master.adp 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,91 @@ + +@title@ + + @context@ + +@context_bar@ + +@header_stuff@ + + + + + Index: openacs-4/packages/soap-gateway/www/master.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/master.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/master.tcl 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,18 @@ +# Expects "title" and "header" and "context_bar" + +if { ![info exists context_bar] } { + set context_bar {} +} + +if ![info exists header_stuff] { + set header_stuff {} +} + +if ![info exists title] { + + # clear + set title {} + +} + +ad_return_template Index: openacs-4/packages/soap-gateway/www/toolbar.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/toolbar.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/toolbar.adp 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,22 @@ + + +
+ + +
+soap-gateway + —  +@caption@ +
+		 + + + + +
 |  + @toolbar.symbol@ +
+
+

+ + Index: openacs-4/packages/soap-gateway/www/toolbar.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/toolbar.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/toolbar.tcl 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,85 @@ +# /packages/soap-gateway/www/toolbar.tcl + +# layout inspired by bug-tracker + +# safety +if ![info exists caption] { + + # clear + set caption {} +} + +# clear for tools +set tools [] + +# add standard tools +set defaults [list help services tests] + +# package id +set pid [soap::package_id -throw f] + +# verify +if { $pid == 0 } { + + # must be just starting out - clear everything + set defaults [list] + +# test for admin user +} elseif { [soap::server::has_permission $pid admin] != 0 } { + + # add em' + lappend defaults admin permissions + +} + +# update tools list +foreach default $defaults { + + # test current list and skip if caption + # ??? if $default equal to caption, then assume $default tool page is current + if { [lsearch $tools $default] < 0 && ![string equal -nocase $default $caption] } { + + # add + lappend tools $default + } +} + +# get href base +set base [soap::get_base_url] + +# create multirow +multirow create toolbar symbol url + +# loop through list +foreach tool $tools { + + # switch + case $tool { + help { + # add + multirow append toolbar help [file join $base doc] + } + services { + # add + multirow append toolbar services [file join $base ] + } + admin { + # add + multirow append toolbar admin [file join $base admin ] + } + tests { + # add + multirow append toolbar tests [file join $base tests ] + } + permissions { + # set href + set url "/permissions/one?object_id=$pid" + + # add + multirow append toolbar permissions $url + + } + } +} + +ad_template_return \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/top.gif =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/top.gif,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/wsdl.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/wsdl.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/wsdl.tcl 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,19 @@ +# packages/soap-gateway/www/wsdl.tcl + +# clear title +set title {} + +# get params from url +set params [soap::server::get_url_params] + +# get interested params +set service [ns_set get $params service] +set oneway [ns_set get $params oneway] +set trace [ns_set get $params trace] +set docs [ns_set get $params documentation] +if ![string length $docs] { set docs 1 } + +# render xml and return +ns_return 200 text/xml [soap::wsdl::generate_wsdl -documentation $docs $service $oneway $trace] + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/admin/delete-method-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/delete-method-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/delete-method-postgresql.xql 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,13 @@ + + + + postgresql7.1 + + + + select method, idl, idl_style, notes + from sg_methods + where method_id = :method_id + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/admin/delete-method.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/delete-method.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/delete-method.adp 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,6 @@ + + + + +Delete the following method: @method@ + Index: openacs-4/packages/soap-gateway/www/admin/delete-method.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/delete-method.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/delete-method.tcl 17 Oct 2004 05:51:56 -0000 1.1 @@ -0,0 +1,55 @@ +# packages/soap-gateway/www/admin/method-namespace.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: delete-method.tcl,v 1.1 2004/10/17 05:51:56 ncarroll Exp $ +} { + namespace_id:integer,notnull + method_id:integer,notnull +} + +# clear title +set title {} + +# get package +set package_id [ad_conn package_id] + +# verify namespace id +soap::method_check $method_id + +# require write permission +ad_require_permission $method_id admin; #write + +# set session context +set context [list "Administration"] + +# create form +template::form create method_form + +# store namespace_id into hidden form element +template::element create method_form namespace_id \ + -widget hidden \ + -datatype text \ + -value $namespace_id + +# store method_id into hidden form element +template::element create method_form method_id \ + -widget hidden \ + -datatype text \ + -value $method_id + +# query for method attributes +db_1row select_method {} + +# test for valid form +if [template::form is_valid method_form] { + + # update existing + soap::method_delete $method_id + + ad_returnredirect "./edit-namespace?namespace_id=$namespace_id" +} + +ad_return_template Index: openacs-4/packages/soap-gateway/www/admin/delete-namespace-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/delete-namespace-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/delete-namespace-postgresql.xql 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,13 @@ + + + + postgresql7.1 + + + + select service, uri, notes + from sg_namespaces + where namespace_id = :namespace_id + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/admin/delete-namespace.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/delete-namespace.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/delete-namespace.adp 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,5 @@ + + + +Delete the following service: @service@ + Index: openacs-4/packages/soap-gateway/www/admin/delete-namespace.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/delete-namespace.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/delete-namespace.tcl 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,48 @@ +# packages/soap-gateway/www/admin/delete-namespace.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: delete-namespace.tcl,v 1.1 2004/10/17 05:51:57 ncarroll Exp $ +} { + namespace_id:integer,notnull +} + +# clear title +set title {} + +# get package +set package_id [ad_conn package_id] + +# verify namespace id +soap::namespace_check $namespace_id + +# require admin permission +ad_require_permission $namespace_id admin; #write + +# set session context to delete mode +set context [list "Administration"] + +# create form +template::form create namespace_form + +# store namespace_id into hidden form element +template::element create namespace_form namespace_id \ + -widget hidden \ + -datatype text \ + -value $namespace_id + +# query for namespace attributes +db_1row namespace_select {} + +# test for valid form +if [template::form is_valid namespace_form] { + + # update existing + soap::namespace_delete $namespace_id + + ad_returnredirect "./" +} + +ad_return_template Index: openacs-4/packages/soap-gateway/www/admin/edit-namespace-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/edit-namespace-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/edit-namespace-postgresql.xql 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,29 @@ + + + + postgresql7.1 + + + + select service, uri, notes + from sg_namespaces + where namespace_id = :namespace_id + + + + + + select method_id, namespace_id, method, idl, idl_style, proc, notes + from sg_methods + where namespace_id = :namespace_id + + + + + + select method, idl, idl_style, proc, notes + from sg_methods + where method_id = :method_id + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/admin/edit-namespace.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/edit-namespace.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/edit-namespace.adp 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,143 @@ + + +@focus@ + + +

+ +

Methods

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
procIDLNotes  
+ + @idl_help@ + + + cancel
+ + @methods.proc@ + + + + @methods.idl@ + + + @methods.notes@  + import 
+ + + @methods.proc@ + + + + @methods.proc;noquote@ + + + + + + + + + @methods.idl;noquote@ + + + @methods.notes;noquote@  + editdelete
+ @idl_help;noquote@ + + +  
+ +

+

Error Descriptions

+ + + + + + + + + + + + + + + + + +
Not PublishedA public Tcl proc within the + @namespace@ + namespace exists that is not published . Selecting import will + add the procedure to the WSDL database. The proc will then be available + for public access using the name specified within ad_proc's + @idl + parameter. If the @idl parameter is missing, the proc's symbolic name will be used instead.
+
Duplicate IDLThe soap-gateway's diff algorithm detected a potential duplicate + method name. The calculated IDL name already exists within the WSDL + database for the @namespace@ namespace. Or, the IDL name for the Tcl proc was + detected within the list of sibling procs not yet published to the WSDL database. + In either case, the Tcl proc cannot be published + until it's IDL name is made unique within the + @namespace@ + namespace.
+
OrphanA published method exists within the WSDL database that has no corresponding + public Tcl proc in the + @namespace@ + namespace. Either delete the entry or supply a public Tcl proc. +
+
ArgumentsA discrepency exists between the arguments of the Tcl proc and the published method in the + WSDL database. Comparisons are made to the argument names only. No type checking is performed. +
+
+ +

There are no methods!

+ +@diffdata@ Index: openacs-4/packages/soap-gateway/www/admin/edit-namespace.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/edit-namespace.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/edit-namespace.tcl 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,492 @@ +# packages/soap-gateway/www/admin/edit-namespace.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: edit-namespace.tcl,v 1.1 2004/10/17 05:51:57 ncarroll Exp $ +} { + namespace_id:integer,notnull,optional + {service ""} + {notes:html ""} + method_id:integer,notnull,optional + {idl ""} + {proc ""} + {method_notes:html ""} + {import 0} +} -properties { + focus +} + +# test for import +if [soap::server::lib::true $import] { + + # test for single method import + if { $proc != {} } { + + # perform single import + set nid [soap::server::lib::import_service \ + -proc $proc $service] + + } else { + + # perform full import + set nid [soap::server::lib::import_service $service] + + # return to admin page + ad_returnredirect . + + } + + # verify args + if { [info exists namespace_id] != 0 && $nid != $namespace_id } { + + # egats + soap::fault::raise "Namespace id mismatch during import" + + } else { + + # set id + set namespace_id $nid + + } + +} + +# clear error +set error {} + +# clear focus +set focus {} + +# init debug var +set diffdata {} + +# get idl help +set idl_help [soap::get_idl_help] + +# get package +set package_id [ad_conn package_id] + +# check to see if namespace_id is assigned +if {[info exists namespace_id]} { + + # verify namespace id + soap::namespace_check $namespace_id + + # require write permission + ad_require_permission $namespace_id admin; #write + + # set session context to edit mode + set context [list "Edit Namespace"] + +} else { + + # require write permission for new namespace + ad_require_permission $package_id admin; #create + + # set session context to creation mode + set context [list "New Namespace"] + +} + +# create form +template::form create namespace_form + +# test for namespace_id assigment +if {[info exists namespace_id]} { + + # set editing + set editing_namespace 1 + +} else { + + # creating + set editing_namespace 0 + +} + +# build service input field +template::element create namespace_form service \ + -datatype text \ + -label "Service" \ + -html { size 32 } \ + -value {}; #$service + +# build notes input field +template::element create namespace_form notes \ + -widget textarea \ + -datatype text \ + -label "Notes" \ + -html { rows 8 cols 80 wrap off } \ + -value {}; #$notes + +# test for valid form +if [template::form is_valid namespace_form] { + + # clear method_id to disable method logic below + if [info exists method_id] { unset method_id } + + # clean up service + set service [string trim $service] + + # try + set err [catch { + + # verify + soap::check_symbol $service + + } error] + + # verify + if { $err } { + + # do nothing + + } else { + + # get session values + set user_id [ad_conn user_id] + set peeraddr [ad_conn peeraddr] + + # force uri to xxxx.openacs.org + set uri "http://$service.openacs.org/methods" + + # look for id of named method + set nid [soap::server::namespace_get_id $service] + + # verify + if { $nid > 0 && (![info exists namespace_id] || $nid != $namespace_id) } { + + # egats + soap::fault::raise "Duplicate service: $service" + } + + # test for assigned namespace id + if [info exists namespace_id] { + + # update existing + soap::server::lib::namespace_update $namespace_id \ + $service $uri $notes + + } else { + + # create new + soap::server::lib::namespace_new $service $uri $notes $user_id $peeraddr $package_id + + # return to admin page + ad_returnredirect . + + } + + # ok return to main list + #ad_returnredirect "./" + + } + +} + +# test for editing +if { $editing_namespace != 0 } { + + # store namespace_id into hidden form element + template::element create namespace_form namespace_id \ + -widget hidden \ + -datatype text \ + -value $namespace_id + + # query for namespace attributes + db_1row namespace_select {} + + # update form elements + template::element set_value namespace_form service $service + template::element set_value namespace_form notes $notes + + # create method form + template::form create method_form + + set method_form:properties(action) edit-namespace + + # test for method_id assigment + if [info exists method_id] { + + # set editing + set editing_method $method_id + + } else { + + # creating + set editing_method 0 + + } + + # store namespace_id into hidden form element + template::element create method_form namespace_id \ + -widget hidden \ + -datatype text \ + -value $namespace_id + + # build idl input field + template::element create method_form idl \ + -datatype text \ + -label "IDL" \ + -html { size 48 } \ + -value {}; #$idl + + # decl procs + set procs2 [list] + + # get source procs and double entries for HTML options + foreach p [soap::get_source_procs $service] { + + # get local + set local [namespace tail $p] + + # append + lappend procs2 [list "$local {[info args $p]}" $local] + + } + + # build proc select + template::element create method_form proc \ + -datatype text \ + -label "Procedure" \ + -widget select \ + -options $procs2 \ + -value $proc + + # build notes input field + template::element create method_form method_notes \ + -widget textarea \ + -datatype text \ + -label "Notes" \ + -html { rows 10 cols 40 wrap off } \ + -value {}; #$notes + + # test for valid form + if { [template::form is_valid method_form] } { + + # try + set err [catch { + + # decompose IDL + set xsd [soap::server::lib::idl_to_xsd "C" $idl] + + # get method + set method [lindex $xsd 1] + + # verify + soap::check_symbol $method + + } error] + + # verify + if { $err } { + + # do nothing + + } else { + + # show + set error $xsd + + # set fixed + set idl_style "C" + + # get session values + set user_id [ad_conn user_id] + set peeraddr [ad_conn peeraddr] + + # look for id of named method + set mid [soap::wsdl::method_get_id $namespace_id $method] + + # verify + if { $mid > 0 && $mid != $editing_method } { + + # egats + soap::fault::raise "Duplicate method: $method" + + } + + # test for assigned method id + if { $editing_method != 0 } { + + # update existing + soap::server::lib::method_update $method_id $method $idl $idl_style $proc $method_notes + + } else { + + # create new + soap::server::lib::method_new $namespace_id $method $idl $idl_style $proc $method_notes $user_id $peeraddr $namespace_id + } + + # clear editing mode + set editing_method 0 + + #ad_returnredirect "./edit-namespace" + } + } + + # get diffs + array set diffs [soap::diff_methods -same t $service] + + if { $editing_method } { + + # query for method attributes + db_1row method_select {} + + # store method_id into hidden form element + template::element create method_form method_id \ + -widget hidden \ + -datatype text \ + -value $method_id + + # set db method values into field elements + template::element set_value method_form idl $idl + template::element set_value method_form proc $proc + template::element set_value method_form method_notes $notes + + } else { + + # clear + template::element set_value method_form proc {} + template::element set_value method_form idl {} + template::element set_value method_form method_notes {} + + } + + # record history list of db entries + set history [list] + + # query methods + db_multirow -extend {edit delete cancel diff} methods \ + namespace_select_all {} { + + # build hot links for edit/delete/... + set edit "edit-namespace?method_id=$method_id&namespace_id=$namespace_id" + set delete "delete-method?method_id=$method_id&namespace_id=$namespace_id" + set cancel "edit-namespace?namespace_id=$namespace_id" + + # init diff code + set diff ERR + + # try + if [catch { + + # get the diff details for $method + set details $diffs($method) + + # get the diff description code + set diff [lindex $details 0] + + # add entry to history list + lappend history $method + + # get the args + set proc [format "$proc {%s}" [lindex $details 1]] + + # check for orphan + if [string equal -nocase -length 4 $diff ORPH] { + + # modify proc to reflect orphan + set proc "#ORPHAN#" + + } + + + } msg] { + + # display error using proc + set proc $msg + + } + + # use hard spaces + regsub -all { } $proc {\ } proc + regsub -all { } $idl {\ } idl + } + + # debug + #set diffdata [array get diffs] + + # scan history list + foreach remove $history { + + # remove entry from diffs array + array unset diffs $remove + + } + + # loop through remaining elements in diffs + foreach proc [array names diffs] { + + # local + set local [namespace tail $proc] + + # build import expression + set import "edit-namespace?namespace_id=$namespace_id&service=$service&import=1&proc=$local" + + # get diff code + set diff [lindex $diffs($proc) 0] + + # describe code + switch $diff { + + UPUB { + set desc {*NOT PUBLISHED*} + } + + DUPL { + set desc {*DUPLICATE IDL*} + } + + default { + set desc {*UNKNOWN ERROR*} + } + + } + + # get proc + set local [format "$local {%s}" [lindex $diffs($proc) 1]] + + # change to hard spaces + regsub -all { } $local {\ } local + + # add to table + multirow append methods -1 $namespace_id {} $desc {} $local {} $import {} {} $diff + + } + + # create goto anchor + set focus "method_form.idl" + +} else { + + # clear + set editing_method 0 + + # clear diffs + array set diffs [list empty {}] +} + + + +# set context +set context "Administration" + +# update caption for toolbar +if $editing_namespace { + + # set to edit + set caption "edit '$service'" + + # create namespace var for help + set namespace [format "::sg::%s" $service] + +} else { + + # set to create + set caption "create service" +} + +ad_return_template Index: openacs-4/packages/soap-gateway/www/admin/index-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/index-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/index-postgresql.xql 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,11 @@ + + + + postgresql7.1 + + + + select namespace_id, service, uri, notes from sg_namespaces + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/admin/index.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/index.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/index.adp 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,126 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +
ServiceNotesStatusEditDeleteWSDL
+ @namespaces.service@ + + @namespaces.notes;noquote@  + @namespaces.status;noquote@editdeletewsdl
+ + +

There are no namespaces

+ +
+

Maintenance

+
    +
  • Manage source libraries.
    • + + + +
  • Import the following unpublished service: @unpublished.service@
    • +     +     + +
  • +Registered Users do not have 'invoke' privileges on the soap-gateway package! Go to Permissions. +
    •  +     + +
  • +The Public do not have 'read' privileges on the soap-gateway package! This may restrict clients from downloading WSDL service specifications. Go to Permissions. + +
    •  +
+

Note: Only public procedures within the sg::<my-namespace>::* will be + imported. Comments are extracted
+ from the source files and can modified once imported.

+ + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Service: + @namespaces.service@ +  
Endpoint: + @namespaces.endpoint@ +  
WSDL: + @namespaces.wsdl@ +  
 force response: + @namespaces.wsdl@ + &oneway=0 
 no documentation: + @namespaces.wsdl@ + &documentation=0 
 trace: + @namespaces.wsdl@ + &trace=http://localhost:8080 
URI + @namespaces.uri@ +  
SOAPActionN/A 
Notes: + @namespaces.notes;noquote@ (more) +  
+ + Index: openacs-4/packages/soap-gateway/www/admin/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/index.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/index.tcl 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,97 @@ +# packages/soap-gateway/www/admin/index.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: index.tcl,v 1.1 2004/10/17 05:51:57 ncarroll Exp $ +} { +} + +# clear title +set title {} + +# installed correctly +if [catch { + + soap::server::lib::true 1 + +}] { + + # report as installation error + error "Failure while calling soap-gateway function!\nDid you restart the server after installing soap-gateway package?\n\n" + +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id admin + +# query namespaces +db_multirow -extend {endpoint edit delete wsdl status} namespaces namespace_list {} { + set endpoint [soap::wsdl::build_endpoint $service] + set edit "edit-namespace?namespace_id=$namespace_id" + set delete "delete-namespace?namespace_id=$namespace_id" + set wsdl [soap::wsdl::build_wsdl_url $service] + + # check for problems + set diffs [soap::diff_methods $service] + if { [llength $diffs] > 0 } { + set status "errors" + } else { + set status "ok" + } +} + +# get permission for object + +# get registered users +set users [acs_magic_object registered_users] + +# test for invoke privileges on package for Registered_users +set ru_invoke [soap::server::has_permission -user_id $users $package_id [soap::server::get_invoke_permission_moniker]] + +# get public +set public [acs_magic_object the_public] + +# test for public read access on WSDL +set pu_read 1;#[soap::server::has_permission -user_id $public $package_id read] + +# create form +template::form create new_namespace_form + +# change action attribute for form - not documented +set new_namespace_form:properties(action) edit-namespace + +# create form +template::form create init_workspace_form + +# change action attribute for form - not documented +set init_workspace_form:properties(action) init-workspace + +# create form +template::form create init_interop_form + +# change action attribute for form - not documented +set init_interop_form:properties(action) init-interop + +# create unpublished rowset +multirow create unpublished service + +# get unpublished +foreach s [soap::query_services -unpublished 1 -published 0] { + + # add to multirow + multirow append unpublished $s + +} + +# set context +set context "Administation" + +# update caption +set caption "admin" + +ad_return_template Index: openacs-4/packages/soap-gateway/www/admin/libraries-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/libraries-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/libraries-postgresql.xql 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,11 @@ + + + + postgresql7.1 + + + + select library_id, path from sg_libraries + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/admin/libraries.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/libraries.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/libraries.adp 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,64 @@ + + + + +

Enter the locations of the source files that will be available for importing + into the soap-gateway.
+ Relative locations will be appended to the acs_root directory. Directory + watches will be converted
+ to wildcard notation and will not recurse; e.g., soap-gateway/lib/*.tcl. The + files are watched by the
+ Request Processor. Refresh to update status.

+

Once the source files are loaded, go back to the admin and + import the services into the soap-gateway.
+

+ + + + + + + + + + + + + + + + + + + +
PathStatusWatch
+ @libraries.path@ + + @libraries.status;noquote@ + remove
 add
+
+ + + + + + + + + + + + + + + + + + + + + +
 StatusMeaning
 ???Library path returned no tcl source files
 okAll file timestamps in the path spec. coincide with APM
 staleAt least one file timestamp in the path spec. does not coincide with APM
+

+ @stat@ +

Index: openacs-4/packages/soap-gateway/www/admin/libraries.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/admin/libraries.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/admin/libraries.tcl 17 Oct 2004 05:51:57 -0000 1.1 @@ -0,0 +1,122 @@ +# packages/soap-gateway/www/admin/libraries.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: libraries.tcl,v 1.1 2004/10/17 05:51:57 ncarroll Exp $ + +} { + library_id:integer,notnull,optional + {delete 0} + {path {}} + {update 0} + {force 0} +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id admin + +# clear status +set stat {} + +# test for delete +if [soap::server::lib::true $delete] { + + # get current + set current [soap::server::lib::library_get_path $library_id] + + # delete + soap::server::lib::library_delete $library_id + + # stop watch + soap::server::lib::watch -stop 1 $current + +} elseif { $path != {} } { + + # test for update + if [info exists library_id] { + + # get current + set current [soap::server::lib::library_get_path $library_id] + + # stop watch + soap::server::lib::watch -stop 1 $current + + # update + soap::server::lib::library_update $library_id $path + + # update - implicit watch + soap::server::lib::update_libraries [list $path] + + } else { + + if [catch { + + # create new library + soap::server::lib::library_new $path + + }] { + + # report + set stat "Error creating new library path:
  $path
Possible duplicate." + + } else { + + # update - implicit watch + soap::server::lib::update_libraries [list $path] + + } + } + +} elseif [soap::server::lib::true $update] { + + # get path from id + set path [soap::server::lib::library_get_path $library_id] + + # update + soap::server::lib::update_libraries [list $path] + +} + +# query namespaces +db_multirow -extend {status remove} libraries library_list {} { + set remove "libraries?library_id=$library_id&delete=1" + if ![soap::server::lib::is_library_valid $path] { + set status "???" + } elseif [soap::server::lib::is_library_dirty $path] { + #set status "stale" + set status "stale" + } else { + set status "ok" + } + +} + +# clear path +set path {} + +# create form +template::form create library_form + +# build path input field +template::element create library_form path \ + -datatype text \ + -label "Path" \ + -html { size "100%" } \ + -value {}; + +# set up path +template::element set_value library_form path "packages//lib/.tcl" + +# set context +set context "Administation" + +# update caption +set caption "admin" + +# return template +ad_return_template Index: openacs-4/packages/soap-gateway/www/doc/folder.gif =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/folder.gif,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/doc/html.bmp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/html.bmp,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/doc/index.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/index.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/doc/index.adp 17 Oct 2004 05:52:00 -0000 1.1 @@ -0,0 +1,120 @@ + +@context@ +@context_bar@ + +

soap-gateway +

+

William Byrne / WilliamB@ByrneLitho.com

+

An experimental OpenACS SOAP package that may prove itself useful.

+

Developed using the following system configuration:

+
    +
  • RedHat 7.3
    • +
  • OpenACS 4.5 (nightly snapshot 10/3/2002)
    • +
  • AOLServer 3.3ad13
    • +
  • nsxml 1.4
    • +
  • PostgreSQL 7.2.1
    • +
+

+

Abstract

+

The soap-gateway is a compilation of server side tcl procedures + and pages that provide Remote Procedure Call (RPC) capabilities to OpenACS servers + for clients using SOAP/HTTP. The implementation is relatively small and maintains + minimal conformity to current SOAP specifications. This document describes the + basic implementation.

+

Table of Contents

+
    +
  1. Overview
    2. +
  2. Installation
    3. +
  3. Samples
    4. +
  4. References
    5. +
  5. License
    6. +
+

Overview (toc)

+

The Simple Object Access Protocol (SOAP) v1.1 + was submitted to W3C on April 18, 2000. Its compatriot + Web Services Description Language (WSDL) was submitted + on March 14, 2001. Together they attempt to unify diverse systems using a form + of XML RPC. Most major software vendors are involved to some extent. Its future + looks bright.

+

SOAP fits nicely into the Client/Server topology. Given a client that needs + some functionality available on a server, SOAP can be used to specify an operation + and its arguments to be submitted by the client to the server. At it's root, + the data representing the operation is fairly basic. If the connection between + the client and server were a TCP wire, a data trace would show about a page + of XML. The XML is not complex and is often decipherable at a glance. The XML + data is specified as a SOAP Envelope. An evolving SOAP + specification defines the Envelope and its progeny. The XML data transmitted + between the client and server is not arbitrary and should conform to a referenced + WSDL instance published by the server. It's the WSDL that defines the published + services and the invocation formats required for execution. The vast majority + of SOAP documentation demonstrates SOAP over HTTP. Another mentioned transport + is SMTP. In each case, the SOAP Envelope follows the respective header as an + XML Payload.

+

Many web servers have been retrofitted to support a SOAP subsystem; e.g., Websphere, + Apache, iPlanet, IIS, etc. There are a handful of SOAP toolkits. To name a few, + MSSOAP Toolkit from Microsoft, AXIS + from Apache, and DataSnap from Borland. A stand alone + Tcl implementation, TclSOAP, is available at Source Forge. + In the Implementation section, I'll get into the + details of my retrofit for OpenACS; the soap-gateway package. Client SOAP examples + using MSSOAP and AXIS can be found in the Samples section.

+

Installation + (toc)

+

Here's a short list of steps required to enable SOAP/HTTP connectivity + to your server. The instructions are brief and assumes the reader has + administrative experience with OpenACS. More details will be available in + a subsequent release.

+
    +
  1. Select the SOAP Gateway from the list of packages that are available for + installation. Install it.
    2. +
  2. Create a sub-site under the Main site and call it 'soap'.
    3. +
  3. Create a new application by selecting the SOAP Gateway.
    4. +
  4. For now, call the new soap-gateway application SOAP Gateway.
    5. +
  5. Refresh this page so this admin + hot link points to the soap-gateway admininistration pages.
    6. +
  6. Under the Maintenance section, you should see unpublished services: 'workspace' + and 'interop'. Import both.
    7. +
  7. In the same section, you may see a message that indicates 'Registered Users' + do not have 'invoke' access on the soap-gateway package. If so, go to the + permissions area for the soap-gateway + instance if you wish to grant 'invoke' rights to registered users.
    8. +
  8. Go to the Samples section and try the test samples. + Take note of the https warning when https'ing.
    9. +
+

Note: Verify 'public' access to your installed 'soap-gateway' + using http and not https. Select the home + of your 'soap-gateway' subsite to retrieve a listing of available services. + Also verify the WSDL for each service can be returned without the need to authenticate + into your server. This will allow clients to enumerate the published services + and retrieve the functional specification for each. Eliminating the need to + authenticate with the server for the purpose of retrieving service WSDLs removes + binding complications for client side SOAP tools.

+

When importing a tcl library into the soap-gateway (i.e., any public methods + under the ::sg::<my-service> namespace), the soap-gateway automatically + grants public 'invoke' rights to any method named 'login'. This gives the client + an opportunity to authenticate into the server before making any other calls.

+

Service libraries shipped with the soap-gateway are located in packages/soap-gateway/lib.

+

Samples (toc)

+

Sample SOAP client applications can be found here.

+

References (toc)

+ +

License (toc)

+

The SOAP Gateway package is subject to the Lesser General + Public License.

+ + Index: openacs-4/packages/soap-gateway/www/doc/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/index.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/doc/index.tcl 17 Oct 2004 05:52:00 -0000 1.1 @@ -0,0 +1,59 @@ +# packages/soap-gateway/www/doc/index.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: index.tcl,v 1.1 2004/10/17 05:52:00 ncarroll Exp $ +} { +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# set context +set context Documentation + +# set context bar +set context_bar [ad_context_bar] + +# update caption +set caption "help" + +# try +if [catch { + + # get href base + set base [soap::get_base_url] + +}] { + + # report as installation error + error "Failure while calling soap-gateway function!\nDid you restart the server after installing soap-gateway package?\n\n" + +} + +# get package id +set pid [soap::package_id -throw f] + +# set href +set permissions "/permissions/one?object_id=$pid" + +# get master +if { 1 || ![string equal [ad_conn package_key] "soap-gateway"] } { + + # ??? + set master "/packages/soap-gateway/www/master" + +} else { + + # same place as base + set master "./$base/master" + +} + +# return template +ad_return_template Index: openacs-4/packages/soap-gateway/www/doc/license.txt =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/license.txt,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/doc/license.txt 17 Oct 2004 05:52:01 -0000 1.1 @@ -0,0 +1,20 @@ +soap-gateway package for OpenACS +Copyright (C) 2003 William Byrne + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this library; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +William Byrne +WilliamB@ByrneLitho.com \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/doc/service-postgresql.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/service-postgresql.xql,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/doc/service-postgresql.xql 17 Oct 2004 05:52:01 -0000 1.1 @@ -0,0 +1,23 @@ + + + + postgresql7.1 + + + + select service, uri, notes + from sg_namespaces + where namespace_id = :nid + + + + + + select method_id, namespace_id, method, idl, idl_style, notes + from sg_methods + where namespace_id = :nid + order by method; + + + + \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/doc/service.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/service.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/doc/service.adp 17 Oct 2004 05:52:01 -0000 1.1 @@ -0,0 +1,27 @@ + +@context@ + + + +
+@service_notes@ +
+ + + + + + +
+ + + +
+
+ +@methods.pretty;noquote@ + +
+@methods.notes;noquote@ +
+
\ No newline at end of file Index: openacs-4/packages/soap-gateway/www/doc/service.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/service.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/doc/service.tcl 17 Oct 2004 05:52:01 -0000 1.1 @@ -0,0 +1,90 @@ +# packages/soap-gateway/www/doc/service.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: service.tcl,v 1.1 2004/10/17 05:52:01 ncarroll Exp $ +} { + service:notnull +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# get namespace id +set nid [soap::server::namespace_get_id $service] + +# check +if { $nid < 0 } { + # throw + soap::fault::raise "Invalid service: $service" +} + +# query for namespace attributes +db_1row namespace_select {} + +# preserve +set service_notes $notes + +# query methods +db_multirow -extend {pretty} methods methods_select {} { + + # set up regexp expression for "C" style function + set expr [soap::wsdl::get_style_parser_expr C] + + # invoke regexp + regexp $expr $idl {} rtyp meth argz + + # get arg parser expr + set expr [soap::wsdl::get_style_parser_expr -argpart 1 C] + + # decl pretty args + set pargs {} + + # loop through args + foreach a [split $argz ,] { + + # split arg type from its name + if ![regexp $expr $a {} atyp nam] { + + # format problem + error "unexpected argument format: $a" + + } + + # add arg + if { $pargs == {} } { + + # set + set pargs "$atyp $nam" + + } else { + + # append + append pargs ", $atyp $nam" + + } + + } + + # make pretty + set pretty "$rtyp $meth($pargs)" + +} + +# set context +set context [list Documentation] + +# update caption +set caption "$service service" + +# return template +ad_return_template + + + + Index: openacs-4/packages/soap-gateway/www/doc/tcl.gif =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/tcl.gif,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/doc/text.gif =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/text.gif,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/doc/www.gif =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/doc/www.gif,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/tests/index.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/index.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/index.adp 17 Oct 2004 05:52:02 -0000 1.1 @@ -0,0 +1,19 @@ + +@context@ + +

Limited interoperability + tests

+

Using Microsoft + SOAP Toolkit

+

Using Apache AXIS Toolkit

+

Refer to the soap-gateway documentation for more + information on how to get the SOAP toolkits.

+ +

SSL connections, SOAP/HTTPS, may not work + correctly. For testing, try launching the demo's using http + instead of https. Service Side Certificates need to be trusted by the Client + software without the need for user confirmation. In other words, the SOAP toolkits + can't handle popup dialogs very well. And we usually get dialogs when the Server's + Certificate cannot be chained to a trusted authority. Free certificates are + available from freessl.com.

+ \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/tests/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/index.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/index.tcl 17 Oct 2004 05:52:02 -0000 1.1 @@ -0,0 +1,36 @@ +# packages/soap-gateway/www/tests/index.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: index.tcl,v 1.1 2004/10/17 05:52:02 ncarroll Exp $ +} { +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# set documentation path +set documentation [file join [ad_conn object_url] doc] + +# set context +set context "Tests" + +# update caption +set caption "tests" + +# is this connection secure +if [ad_secure_conn_p] { + + # calc http name + set http [format "http://%s%s" [ns_info hostname] [file join / [soap::get_base_url] tests]] + +} + +# return template +ad_return_template + Index: openacs-4/packages/soap-gateway/www/tests/axis/axis.zip =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/axis/axis.zip,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/tests/axis/index.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/axis/index.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/axis/index.adp 17 Oct 2004 05:52:04 -0000 1.1 @@ -0,0 +1,5 @@ + +@context@ + +Download the following archive and refer to the enclosed documentation.
+See the references section for links to AXIS. \ No newline at end of file Index: openacs-4/packages/soap-gateway/www/tests/axis/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/axis/index.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/axis/index.tcl 17 Oct 2004 05:52:04 -0000 1.1 @@ -0,0 +1,27 @@ +# packages/soap-gateway/www/test/axis/index.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: index.tcl,v 1.1 2004/10/17 05:52:04 ncarroll Exp $ +} { +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# set context +set context [list [list .. Tests] {AXIS}] + +# update caption +set caption "axis toolkit" + +# update references +set references [file join [ad_conn object_url] doc #References] + +# return template +ad_return_template Index: openacs-4/packages/soap-gateway/www/tests/mssoap/bio-small.jpg =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/bio-small.jpg,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/tests/mssoap/bio.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/bio.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/mssoap/bio.adp 17 Oct 2004 05:52:05 -0000 1.1 @@ -0,0 +1,172 @@ + +@context@ + + +

workspace::setName

+
+ + + + + + + +
User
+ Password
+ +    + +

+ + + + + + + +
+ + First Name
+ + Last Name
+ +
+
+ + + + +
Debug Trace (e.g., http://locahost:8080)
+
+ Disable one-way's
+
Index: openacs-4/packages/soap-gateway/www/tests/mssoap/bio.jpg =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/bio.jpg,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/tests/mssoap/bio.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/bio.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/mssoap/bio.tcl 17 Oct 2004 05:52:05 -0000 1.1 @@ -0,0 +1,24 @@ +# packages/soap-gateway/www/test/mssoap/index.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: bio.tcl,v 1.1 2004/10/17 05:52:05 ncarroll Exp $ +} { +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# set context +set context [list [list .. Tests] {MS SOAP}] + +# update caption +set caption "bio test" + +# return template +ad_return_template Index: openacs-4/packages/soap-gateway/www/tests/mssoap/echo-small.jpg =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/echo-small.jpg,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/tests/mssoap/echo.jpg =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/echo.jpg,v diff -u Binary files differ Index: openacs-4/packages/soap-gateway/www/tests/mssoap/index.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/index.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/mssoap/index.adp 17 Oct 2004 05:52:05 -0000 1.1 @@ -0,0 +1,24 @@ + +@context@ + + + + + +
To run the following tests, you'll need IE and the MSSOAP + Toolkit
+
+More than likely, you'll experience a security issue when attempting to instantiate the +MSSOAP Toolkit from within a page that originated from an untrusted server. Adding your trusted server to the list of Trusted Servers in IE should help. +
+
+ + + + + +
+

+

Basic Interop Tests

 +

+

User Bio

Index: openacs-4/packages/soap-gateway/www/tests/mssoap/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/index.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/mssoap/index.tcl 17 Oct 2004 05:52:05 -0000 1.1 @@ -0,0 +1,27 @@ +# packages/soap-gateway/www/test/mssoap/index.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: index.tcl,v 1.1 2004/10/17 05:52:05 ncarroll Exp $ +} { +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# set context +set context [list [list .. Tests] {MS SOAP}] + +# update caption +set caption "mssoap toolkit" + +# update references +set references [file join [ad_conn object_url] doc #References] + +# return template +ad_return_template Index: openacs-4/packages/soap-gateway/www/tests/mssoap/interop.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/interop.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/mssoap/interop.adp 17 Oct 2004 05:52:05 -0000 1.1 @@ -0,0 +1,198 @@ + +@context@ + + +

interop::echo* test

+
+ + + + + + + +
User
+ Password
+ +    + +
+
+ + + + + + + + + + + + + + + + + + + + + +
String + +
Integer
Float
Void
+
+
+ + + + +
Debug Trace (e.g., http://locahost:8080)
+
+ Disable one-way's
+
Index: openacs-4/packages/soap-gateway/www/tests/mssoap/interop.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/interop.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/soap-gateway/www/tests/mssoap/interop.tcl 17 Oct 2004 05:52:05 -0000 1.1 @@ -0,0 +1,24 @@ +# packages/soap-gateway/www/test/mssoap/interop.tcl + +ad_page_contract { + + @author WilliamB@ByrneLitho.com + @creation-date 2002-12-23 + @cvs-id $Id: interop.tcl,v 1.1 2004/10/17 05:52:05 ncarroll Exp $ +} { +} + +# get package id +set package_id [ad_conn package_id] + +# require read permission +ad_require_permission $package_id read + +# set context +set context [list [list .. Tests] {MS SOAP}] + +# update caption +set caption "interop test" + +# return template +ad_return_template Index: openacs-4/packages/soap-gateway/www/tests/mssoap/trusted.jpg =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/soap-gateway/www/tests/mssoap/trusted.jpg,v diff -u Binary files differ