Initial

intranet-xmlrpc.info

+<?xml version="1.0"?>
+<!-- Generated by the OpenACS Package Manager -->
+
+<package key="intranet-xmlrpc" url="http://openacs.org/repository/apm/packages/intranet-xmlrpc" type="apm_application">
+    <package-name>Intranet XML-RPC Interface</package-name>
+    <pretty-plural>Intranet XML-RPC Interface</pretty-plural>
+    <initial-install-p>f</initial-install-p>
+    <singleton-p>f</singleton-p>
+    <auto-mount>intranet-xmlrpc</auto-mount>
+
+    <version name="3.2.0.0.0" url="http://openacs.org/repository/download/apm/intranet-xmlrpc-3.2.0.0.0.apm">
+        <owner url="mailto:frank.bergmann@project-open.com">Frank Bergmann</owner>
+        <summary>XML-RPC interface to the database API</summary>
+        <vendor url="http://www.project-open.com/">]project-open[</vendor>
+        <description format="text/plain">Provides an XML-RPC wrapper that allows the users to access to the PlPg/SQL database API and to retreive information about business objects via a 'select * from objects where ...' statement. Authentication is performed via an auth-token. Security is handleled by HTTPS.</description>
+
+        <provides url="intranet-xmlrpc" version="3.2.0.0"/>
+        <requires url="acs-kernel" version="5.1"/>
+        <requires url="xml-rpc" version="0.1"/>
+
+        <callbacks>
+        </callbacks>
+        <parameters>
+        <!-- No version parameters -->
+        </parameters>
+
+    </version>
+</package>

tcl/intranet-xmlrpc-init.tcl

+# /packages/intranet-xmlrpc/tcl/intranet-xmlrpc-init.tcl
+ad_library {
+     Register intranet-xmlrpc  procs
+     @author Frank Bergmann (frank.bergmann@project-open.com)
+}
+
+xmlrpc::register_proc sqlapi.login
+

tcl/intranet-xmlrpc-procs.tcl

+# /packages/intranet-xmlrpc/tcl/intranet-xmlrpc-procs.tcl
+#
+# Copyright (C) 2003-2006 Project/Open
+#
+# All rights reserved. Please check
+# http://www.project-open.com/license/ for details.
+
+ad_library {
+    Provides a XML-RPC interface to the ]project-open[
+    data model. The API works by wrapping generic SQL
+    statements into XML-RPC
+
+    @author frank.bergmann@project-open.com
+    @creation-date 2006-07-01
+    @cvs-id $Id: syst
+}
+
+# ----------------------------------------------------------------------
+# 
+# ----------------------------------------------------------------------
+
+ad_proc -public im_package_xmlrpc_id {} {
+    Returns the package id of the intranet-forum module
+} {
+    return [util_memoize "im_package_xmlrpc_id_helper"]
+}
+
+ad_proc -private im_package_xmlrpc_id_helper {} {
+    return [db_string im_package_core_id {
+        select package_id from apm_packages
+        where package_key = 'intranet-xmlrpc'
+    } -default 0]
+}
+
+
+# ----------------------------------------------------------------------
+# sqlapi procedures
+# ----------------------------------------------------------------------
+
+
+ad_proc -public sqlapi.select { email token object_type object_id } {
+    Retreives all information for an object of a given object type
+} {
+    ns_log Notice "sqlapi.select: email=$email, token=$token, object_type=$object_type, object_id=$object_id"
+
+    set user_id [db_string user_id "select party_id from parties where email=:email" -default 0]
+    set login_p [im_valid_auto_login_p -user_id $user_id -auto_login $token]
+
+    if {!$login_p} { return [list -string "invalid_auth_token"] }
+
+    set object_table [db_string object_table "select table_name from acs_object_types where object_type=:object_type" -default ""]
+    set id_column [db_string id_column "select id_column from acs_object_types where object_type=:object_type" -default ""]
+
+    set query "select * from $object_table where $id_column = $object_id"
+    ns_log Notice "sqlapi.select: object_table=$object_table, id_column=$id_column, sql=$query"
+
+    db_with_handle db {
+	set selection [ns_db select $db $query]
+	if {[ns_db getrow $db $selection]} {
+
+	    set result [list]
+	    for {set i 0} {$i < [ns_set size $selection]} {incr i} {
+		set column [ns_set key $selection $i]
+		set value [ns_set value $selection $i]
+		ns_log Notice "sqlapi.select: i=$i, column=$column, value=$value"
+		
+		lappend result $column
+		lappend result [list -string $value]
+	    }
+
+	    # Skip any possibly remaining records
+	    ns_db flush $db
+	    
+	    # Return the key-value list as a "struct"
+	    return [list -struct $result]
+	} else {
+
+	    return [list -string no_records_found]
+
+	}
+    }
+}
+
+
+ad_proc -public sqlapi.login {email password} {
+    Returns an authentication token of the user provides
+    us with a valid email/password
+
+    @return A list composed of 1. a status and 2. a token or
+            an error message. Status can be "ok", or anything
+            else such as "bad_password" etc.
+
+    @author Frank Bergmann (frank.bergmann@project-open.com)
+} {
+    # Authority - Who is responsible to log the dude in?
+    set authority_options [auth::authority::get_authority_options]
+    set authority_id [lindex [lindex $authority_options 0] 1]
+
+    # Check username and password
+    array set auth_info [auth::authenticate \
+                             -return_url "" \
+                             -authority_id $authority_id \
+                             -email [string trim $email] \
+                             -password $password \
+    ]
+
+    # Handle authentication problems
+    switch $auth_info(auth_status) {
+        ok {
+	    set user_id $auth_info(user_id)
+	    set sec_token [im_generate_auto_login -user_id $user_id]
+	    return [list -array [list [list -string $auth_info(auth_status)] [list -string $sec_token]]]
+        }
+        default {
+
+	    return [list -array [list [list -string $auth_info(auth_status)] [list -string $auth_info(auth_message)]]]
+        }
+    }
+}
+
+

www/login.tcl

+ad_page_contract {
+    Autenticate the user and issue an auth-token
+    that needs to be specified for every xmlrpc-request
+    
+    @author Frank Bergmann (frank.bergmann@project-open.com)
+} {
+    user_id 
+    password
+    
+}
+
+
+# ------------------------------------------------------------
+# Security & Defaults
+# ------------------------------------------------------------
+
+set return_url "[ad_conn url]?[ad_conn query]"
+set page_title "Load Update Information"
+set context_bar [im_context_bar $page_title]
+
+set package_root_dir [acs_package_root_dir "intranet-update-server"]
+set file "$package_root_dir/update.xml"
+
+ns_log Notice "update: before authority_options"
+
+set authority_options [auth::authority::get_authority_options]
+if { ![exists_and_not_null authority_id] } {
+    set authority_id [lindex [lindex $authority_options 0] 1]
+}
+
+# Register the interaction if intranet-crm-tracking is installed
+if {[db_table_exists crm_online_interactions]} {
+
+    catch {crm_basic_interaction -interaction_type_id [crm_asus_login] -email $email -password $password} errmsg
+
+}
+
+array set auth_info [auth::authenticate \
+	-return_url $return_url \
+        -authority_id $authority_id \
+	-email [string trim $email] \
+	-password $password 
+]
+
+ns_log Notice "update: after authenticate: status=$auth_info(auth_status)"
+
+
+# Handle authentication problems
+set successful_login 0
+set login_message ""
+set login_status ""
+switch $auth_info(auth_status) {
+    ok {
+	set successful_login 1
+	set login_status "ok"
+	set login_message "Successful Login"
+    }
+    bad_password {
+	set login_status "fail"
+	set login_message "Bad password. Your password doesn't match your user name."
+    }
+    default {
+	set login_status "fail"
+	set login_message "Authentication error. There was an error during authentification. Please check your email and password."
+    }
+}
+
+# Not a successul login...
+if {!$successful_login} {
+    set error_xml "
+	<po_software_update>
+	  <login>
+	    <login_status>$login_status</login_status>
+	    <login_message>$login_message</login_message>
+	  </login>
+	  <account>
+	  </account>
+	  <update_list>
+	  </update_list>
+	</po_software_update>\n"
+    doc_return 500 text/xml $error_xml
+    return
+}
+
+# ------------------------------------------------------------
+# Successful Login
+# ------------------------------------------------------------
+
+# Check the users's cvs_user and cvs_password fields
+set cvs_user "anonymous"
+set cvs_password ""
+set auth_user_id $auth_info(user_id)
+
+if {[db_column_exists persons cvs_user]} {
+    db_0or1row cvs_info "
+	select
+		cvs_user,
+		cvs_password
+	from
+		persons
+	where
+		person_id = :auth_user_id
+    "
+}
+
+# Currently: No check if cvs_user was "" (no account):
+# We allow everybody to check the server as "anonymous"
+
+
+# update.xml file for some reason unavailable
+if {![file readable $file]} {
+    set error_xml "
+	<po_software_update>
+	  <login>
+	    <login_status>fail</login_status>
+	    <login_message>Internal Server Error: File not readable. 
+	    Please notify support@project-open.com.</login_message>
+	  </login>
+	  <account>
+	  </account>
+	  <update_list>
+	  </update_list>
+	</po_software_update>\n"
+    doc_return 500 text/xml $error_xml
+    return
+}
+
+
+# Everything OK so far, so let's get the update.xml file
+if {[catch {
+
+    ns_log Notice "update: Opening $file"
+    set fileChan [open $file]
+    ns_log Notice "update: fileChan=$fileChan"
+    ns_log Notice "update: before gets"
+    while {[gets $fileChan line] >= 0} {
+#	ns_log Notice "update: getting line..."
+	append update_xml "$line\n"
+    }
+    ns_log Debug "update: Done copying data."
+    close $fileChan
+    
+} errmsg]} {
+
+    # Try to close the channel anyway
+    catch { [close $fileChan]} errmsg1
+    
+    # update.xml file for some reason unavailable
+    set error_xml "
+		<po_software_update>
+		  <login>
+		    <login_status>fail</login_status>
+		    <login_message>Internal Server Error: Error accessing data. 
+		    Please notify support@project-open.com.</login_message>
+		  </login>
+		  <account>
+		  </account>
+		  <update_list>
+		  </update_list>
+		</po_software_update>\n"
+    doc_return 500 text/xml $error_xml
+    return
+}
+	
+
+# Add the CVS login information and return the result
+set tree ""
+if { [catch {
+
+    ns_log Notice "update: before parsing the XML file"
+    set tree [xml_parse -persist $update_xml]
+    set root_node [$tree documentElement]
+    set login_node [$root_node selectNodes {//login}]
+    
+    ns_log Notice "update: before adding cvs login information"
+    $login_node appendXML "<cvs_user>$cvs_user</cvs_user>"
+    $login_node appendXML "<cvs_password>$cvs_password</cvs_password>"
+    
+    ns_log Notice "update: before asXML return"
+    doc_return 200 text/xml [$tree asXML]
+    xml_doc_free $tree
+    return
+	    
+} errmsg] } {
+
+    # update.xml file for some reason unavailable
+    set error_xml "
+		<po_software_update>
+		  <login>
+		    <login_status>fail</login_status>
+		    <login_message>
+	              Internal Server Error: Error parsing the server-side XML file. 
+		      Please notify support@project-open.com.
+	              $errmsg
+                    </login_message>
+		  </login>
+		  <account>
+		  </account>
+		  <update_list>
+		  </update_list>
+		</po_software_update>\n"
+    if {"" != $tree} { xml_doc_free $tree }
+    doc_return 500 text/xml $error_xml
+    return
+}
+