pax_global_header 0000666 0000000 0000000 00000000064 13175625757 0014534 g ustar 00root root 0000000 0000000 52 comment=bc879801ae31d526843ffd7aa766906ce208e7f4
intranet-rest-v5-0-2-4-1/ 0000775 0000000 0000000 00000000000 13175625757 0015022 5 ustar 00root root 0000000 0000000 intranet-rest-v5-0-2-4-1/catalog/ 0000775 0000000 0000000 00000000000 13175625757 0016434 5 ustar 00root root 0000000 0000000 intranet-rest-v5-0-2-4-1/catalog/intranet-rest.de_DE.ISO-8859-1.xml 0000664 0000000 0000000 00000001242 13175625757 0024115 0 ustar 00root root 0000000 0000000
REST-APIREST - Kategorie TypREST - GruppenmitgliedschaftREST - Meine StundenREST - Meine Projekte und AufgabenREST - Meine Projekte und StundenREST - Berechtigungen für ObjekteREST-Systemberichte
intranet-rest-v5-0-2-4-1/catalog/intranet-rest.en_US.ISO-8859-1.xml 0000664 0000000 0000000 00000001203 13175625757 0024163 0 ustar 00root root 0000000 0000000
REST APIREST Category TypeREST Group MembershipsREST My HoursREST My Timesheet ProjectREST My Timesheet Projects and HoursREST Object PermissionsREST System Reports
intranet-rest-v5-0-2-4-1/catalog/intranet-rest.pl_PL.utf-8.xml 0000664 0000000 0000000 00000001171 13175625757 0023724 0 ustar 00root root 0000000 0000000
REST APIREST Category TypeREST Group MembershipsREST My HoursREST My Timesheet ProjectREST My Timesheet Projects and HoursREST Object PermissionsREST System Reports
intranet-rest-v5-0-2-4-1/intranet-rest.info 0000664 0000000 0000000 00000002454 13175625757 0020503 0 ustar 00root root 0000000 0000000
]project-open[ REST Web Service Interface]project-open[ REST Web Service Interfaceftintranet-restFrank BergmannExpose the ]project-open[ data-model as a Web Service in REST style2016-11-15]project-open[Provides read and write access to all important ]po[ objects.
intranet-rest-v5-0-2-4-1/perl/ 0000775 0000000 0000000 00000000000 13175625757 0015764 5 ustar 00root root 0000000 0000000 intranet-rest-v5-0-2-4-1/perl/ProjectOpen.pm 0000775 0000000 0000000 00000026262 13175625757 0020565 0 ustar 00root root 0000000 0000000 #----------------------------------------------------------------
# ]project-open[ REST Interface
#
# (c) Frank Bergmann, 2014-09-24
# Version 3
# Released under GPL V2.0 or higher
#
# $Id$
#
#----------------------------------------------------------------
package ProjectOpen;
use strict;
use warnings;
use HTTP::Request;
use LWP::UserAgent;
use Data::Dumper;
use JSON;
use Try::Tiny;
use Class::Data::Inheritable;
use HTTP::Request::Common qw{ POST };
require Class::Data::Inheritable;
require Class::Accessor;
use base qw/Class::Data::Inheritable Class::Accessor/;
# Define class variables:
#
__PACKAGE__->mk_classdata("host"); # domain name of ]po[ REST host
__PACKAGE__->mk_classdata("email"); # email of the user accessing
__PACKAGE__->mk_classdata("password"); # password for email
__PACKAGE__->mk_classdata("debug"); # 0=silent, 9=very verbose
__PACKAGE__->mk_classdata("category_cache"); # Cache for category values
__PACKAGE__->mk_classdata("object_cache"); # Cache for category values
# Default variable values. demo.project-open.net will continue to
# provide a user bbigboss/ben with access to most REST objects.
#
use constant DEFAULT_ARGS => (
"host" => "demo.project-open.net",
"email" => "bbigboss\@tigerpond.com",
"password" => "ben",
"debug" => 1
);
# Get arguments. This private method is used in the constructor
# to get it's arguments.
#
sub _get_args {
my $proto = shift;
my %args;
if (scalar(@_) > 1) {
if (@_ % 2) { print STDERR "ProjectOpen: new: odd number of parameters"; }
%args = @_;
} elsif (ref $_[0]) {
unless (eval {local $SIG{'__DIE__'}; %{$_[0]} || 1}) {
print STDERR "ProjectOpen: new: not a hashref in args";
}
%args = %{$_[0]};
} else {
%args = ('q' => shift);
}
return {$proto->DEFAULT_ARGS, %args};
}
# Constructor. Takes an optional var => value list and stores in
# class variables.
#
sub new {
my $class = shift;
my $args = $class->_get_args(@_);
# Write arguments into class variables
$class->host($args->{host});
$class->email($args->{email});
$class->password($args->{password});
$class->debug($args->{debug});
# Initialize caches for objects and categories
$class->object_cache({});
$class->category_cache({});
# Print out some debug information
my $debug = $class->debug;
print STDERR sprintf "ProjectOpen: new: host=%s, email=%s, pwd=%s\n", $class->host, $class->email, $class->password if ($debug > 0);
return $class;
}
# Low-level HTTP request to retrieve an XML page from ]project-open[.
# Higher-level procedures will use this procecure to retreive specific
# objects.
# Example: _http_get_request("/intranet-rest/im_conf_item");
# Parameters:
# self: reference to ProjectOpen class
# path: the path to the resource ('/intranet-rest/')
#
sub _http_get_request {
my $self = shift;
my $uri = shift;
# Show some debug messages
my $debug = ProjectOpen->debug;
print STDERR sprintf "ProjectOpen: get_request: uri=%s using email=%s, pwd=%s\n",
$uri, ProjectOpen->email, ProjectOpen->password if ($debug > 3);
# Perform the HTTP request. The request is authenticated using Basic Auth.
my $ua = LWP::UserAgent->new;
my $req = HTTP::Request->new(GET => $uri);
$req->authorization_basic(ProjectOpen->email, ProjectOpen->password);
my $res = $ua->request($req);
print STDERR sprintf "ProjectOpen: request: HTTP request failed: %s\n",
$res->status_line unless $res->is_success;
print STDERR sprintf "ProjectOpen: content=%s\n", $res->content if ($debug > 5);
# Parse the returned data and return the result
my $json;
eval {
$json = decode_json($res->content);
};
if ($@) {
my $json_error = "{\"success\": false, \"message\": \"Error parsing JSON: $@\"}";
$json = decode_json($json_error);
}
return $json;
}
# Low-level HTTP request to write data to ]project-open[.
# Higher-level procedures will use this procecure to retreive specific
# objects.
# Example: _http_post_request("/intranet-rest/im_conf_item", $hash);
# Parameters:
# self: reference to ProjectOpen class
# path: the path to the resource ('/intranet-rest/')
# hash: a hash with variable->value pairs to write into the object
#
sub _http_post_request {
my $self = shift;
my $uri = shift;
my $hash = shift;
# Show some debug messages
my $debug = ProjectOpen->debug;
print STDERR sprintf "ProjectOpen: _http_post_request: uri=%s using email=%s, pwd=%s\n",
$uri, ProjectOpen->email, ProjectOpen->password if ($debug > 3);
print STDERR "ProjectOpen: _http_post_request: " . Dumper($hash) . "\n" if ($debug > 5);
my $hash_as_json = encode_json($hash);
print STDERR "ProjectOpen: _http_post_request: encoded hash as JSON: " . $hash_as_json . "\n" if ($debug > 5);
# Perform the HTTP request. The request is authenticated using Basic Auth.
my $ua = LWP::UserAgent->new;
my $req = HTTP::Request->new(POST => $uri);
$req->authorization_basic(ProjectOpen->email, ProjectOpen->password);
$req->content($hash_as_json);
my $res = $ua->request($req);
print STDERR sprintf "ProjectOpen: request: HTTP request failed: %s\n",
$res->status_line unless $res->is_success;
print STDERR sprintf "ProjectOpen: content=%s\n", $res->content if ($debug > 5);
# Parse the returned data and return the result
my $json;
eval {
$json = decode_json($res->content);
};
if ($@) {
my $json_error = "{\"success\": false, \"message\": \"Error parsing JSON: $@\"}";
$json = decode_json($json_error);
}
return $json;
}
# Low-level HTTP request to write data to ]project-open[.
# Higher-level procedures will use this procecure to retreive specific
# objects.
# Example: _http_delete_request("/intranet-rest/im_project/12345");
# Parameters:
# self: reference to ProjectOpen class
# path: the path to the resource ('/intranet-rest/object_type/object_id')
#
sub _http_delete_request {
my $self = shift;
my $uri = shift;
# Show some debug messages
my $debug = ProjectOpen->debug;
print STDERR sprintf "ProjectOpen: _http_delete_request: uri=%s using email=%s, pwd=%s\n",
$uri, ProjectOpen->email, ProjectOpen->password if ($debug > 3);
# Perform the HTTP request. The request is authenticated using Basic Auth.
my $ua = LWP::UserAgent->new;
my $req = HTTP::Request->new(DELETE => $uri);
$req->authorization_basic(ProjectOpen->email, ProjectOpen->password);
my $res = $ua->request($req);
print STDERR sprintf "ProjectOpen: request: HTTP request failed: %s\n",
$res->status_line unless $res->is_success;
print STDERR sprintf "ProjectOpen: content=%s\n", $res->content if ($debug > 5);
# Parse the returned data and return the result
my $json;
eval {
$json = decode_json($res->content);
};
if ($@) {
my $json_error = "{\"success\": false, \"message\": \"Error parsing JSON: $@\"}";
$json = decode_json($json_error);
}
return $json;
}
# Retreive a list of objects of a certain type.
# Example: get_object_list("im_conf_item");
# Parameters:
# object_type: ]po[ object type ('im_project', 'im_conf_item', ...)
# sql_query: A SQL query selecting out only objects that satisfy
# some condition. Ex: 'project_status_id=76' for
# selecting only projects with status 'open'.
#
sub get_object_list {
my $self = shift;
my $object_type = shift;
my $sql_query = shift;
my $host = ProjectOpen->host;
my $uri = URI->new("http://$host/intranet-rest/$object_type");
if (defined $sql_query) {
$uri->query_form("query" => $sql_query, "format" => "json");
} else {
$uri->query_form("format" => "json");
}
my $res = ProjectOpen->_http_get_request($uri);
return $res;
}
# Retreive a single object.
# Example: get_object("user", 624); # should return info about user "System Administrator"
# Parameters:
# object_type: ]po[ object type ('im_project', 'im_conf_item', ...)
# object_id: The ID of the object. Every object in ]po[ has a
# unique ID.
#
sub get_object {
my $self = shift;
my $object_type = shift;
my $object_id = shift;
# Check if we already got the value for this object_id
# or get the value from the REST server
my $o_cache = ProjectOpen->object_cache;
my $o_json;
if (defined $o_cache->{$object_id}) {
$o_json = $o_cache->{$object_id};
} else {
# Get the object from the REST server
my $host = ProjectOpen->host;
my $uri = URI->new("http://$host/intranet-rest/$object_type/$object_id?format=json");
$uri->query_form("format" => "json");
$o_json = ProjectOpen->_http_get_request($uri);
# Store in cache
$o_cache->{$object_id} = $o_json;
}
return $o_json;
}
# Get the string value of a category. Categories are a kind of constants in ]po[.
# This procedure thakes the ID of a category and will return the pretty name.
# Parameters:
# category_id: A category_id value
#
sub get_category {
my $self = shift;
my $category_id = shift;
# Check if we already got the value for this category_id
# or get the value from the REST server
my $debug = ProjectOpen->debug;
my $cat_cache = ProjectOpen->category_cache;
my $cat_hash;
if (defined $cat_cache->{$category_id}) {
$cat_hash = $cat_cache->{$category_id};
} else {
# Get the category from the REST server
my $uri = URI->new("/intranet-rest/im_category/$category_id?format=json");
$cat_hash = ProjectOpen->_http_get_request($uri);
# Store in cache
$cat_cache->{$category_id} = $cat_hash;
}
my $category = $cat_hash->{category};
return $category;
}
# Get group memberships for a specific user.
# The procedure returns an array of group_id -> $value hashs
# Parameters:
# object_id: ID of a ]po[ user
#
sub get_group_memberships {
my $self = shift;
my $object_id = shift;
# Don't cache this. These results are unlikely to be used again.
my $host = ProjectOpen->host;
my $uri = URI->new("http://$host/intranet-reporting/view?format=json");
$uri->query_form(
"report_code" => "rest_group_membership",
"object_id" => $object_id,
"format" => "json"
);
my $membership_json = ProjectOpen->_http_get_request($uri);
my $list = $membership_json->{data};
return $list;
}
# Update a single object.
# Example: post_object("user", 8898);
# This should update the data of the user "Bobby Bizconsult" if the
# authenticated user has write permissions (i.e. SysAdmin).
#
# Parameters:
# object_type: ]po[ object type ('im_project', 'im_conf_item', ...)
# object_id: The ID of the object. Every object in ]po[ has a unique ID.
# json: Hash with variables to update
#
sub post_object {
my $self = shift;
my $object_type = shift;
my $object_id = shift;
my $json = shift;
my $debug = ProjectOpen->debug;
print STDERR sprintf "ProjectOpen: post_object: object_type=%s, object_id=%s\n", $object_type, $object_id if ($debug > 0);
print STDERR sprintf "ProjectOpen: post_object: json=%s\n", $object_type, $object_id, Dumper($json) if ($debug > 8);
# Get the object from the REST server
my $host = ProjectOpen->host;
my $uri = URI->new("http://$host/intranet-rest/$object_type/$object_id");
my $o_json = ProjectOpen->_http_post_request($uri, $json);
return $o_json;
}
1;
intranet-rest-v5-0-2-4-1/perl/example.perl 0000775 0000000 0000000 00000010224 13175625757 0020305 0 ustar 00root root 0000000 0000000 # --------------------------------------------------------
# Access the ]project-open[ REST Web-Service
# Example
# (c) 2010 ]project-open[
# Author: Frank Bergmann
# --------------------------------------------------------
use strict;
use ProjectOpen;
use Data::Dumper;
# --------------------------------------------------------
# Connection parameters:
# Debug: 0=silent, 9=very verbose
my $debug = 5;
# benbigboss/ben is a default user @ demo.project-open.net...
#
my $rest_server = "demo.project-open.net";
$rest_server = "localhost:8000";
my $rest_email = "bbigboss\@tigerpond.com";
my $rest_password = "ben";
# Create a generic access object to query the ]po[ HTTP server
#
ProjectOpen->new (
host => $rest_server,
email => $rest_email,
password => $rest_password,
debug => $debug
);
# -------------------------------------------------------
# Get the list of users with a "cvs_user" field which is not null.
# As a result we will receive a hash reference with user_id ->
# We can then take the user_id to get more information about that user.
#
my $user_json = ProjectOpen->get_object_list("user", "person_id > 10000");
print "example.perl: " . Dumper($user_json) if ($debug > 5);
my @users = @{$user_json->{'data'}};
# -------------------------------------------------------
# Get the group memberships for each user
#
foreach my $u (@users) {
my $user_id = $u->{'user_id'};
print "example.perl: user_id=" . $user_id . ", username=" . $u->{'username'} . "\n";
# Get more information about the user
my $user_hash = ProjectOpen->get_object("user", $user_id);
print Dumper($user_hash) if ($debug > 5);
# Extract some variables from hash
my $username = $user_hash->{username};
my $cvs_user = $user_hash->{cvs_user};
my $first_names = $user_hash->{first_names};
my $last_name = $user_hash->{last_name};
print "example.perl: Found user '$first_names $last_name' with user_id=$user_id, cvs_user=$cvs_user\n" if ($debug > 0);
# Get the list of group memberships of the user
my $group_array = ProjectOpen->get_group_memberships($user_id);
print Dumper($group_array) if ($debug > 5);
# Loop through the list of groups
my $array_size = @{$group_array};
for (my $count = 0; $count < $array_size; $count++) {
# Access the hash at the position $count of the array
my $val_hash = $group_array->[$count];
# The hash has a value "group_id" which we need.
my $group_id = $val_hash->{group_id};
# Skip special groups ("The Public" and "Registered Users")
# with negative group_id
next if ($group_id < 0);
# Get the details of the group
my $group_hash = ProjectOpen->get_object("group", $group_id);
my $group_name = $group_hash->{group_name};
my $group_object_type = $group_hash->{object_type};
# We are looking for groups with group_type = "im_cvs_group".
# We have created this special group_type in ]po[ to separate
# these groups from "im_profile" and other groups.
next if ($group_object_type ne "im_cvs_group");
print "example.perl: group_id=$group_id, group_name=$group_name\n" if ($debug > 0);
}
}
exit 0;
# -------------------------------------------------------
# Get the list of configuration items of type "CVS Repository"
#
my $conf_item_list = ProjectOpen->get_object_list("im_conf_item");
print Dumper($conf_item_list) if ($debug > 5);
# -------------------------------------------------------
# Get the list of IDs of the Conf Items
#
my $list = $conf_item_list->{object_id};
for my $object_id (keys %$list) {
print "example.perl: Found conf_item_id=$object_id\n" if ($debug > 5);
my $conf_item = ProjectOpen->get_object("im_conf_item", $object_id);
print Dumper($conf_item) if ($debug > 5);
my $conf_item_name = $conf_item->{conf_item_name};
my $conf_item_status_id = $conf_item->{conf_item_status_id}->{content};
my $conf_item_type_id = $conf_item->{conf_item_type_id}->{content};
my $conf_item_status = ProjectOpen->get_category($conf_item_status_id);
my $conf_item_type = ProjectOpen->get_category($conf_item_type_id);
print "example.perl: name=$conf_item_name, status=$conf_item_status, type=$conf_item_type\n" if ($debug);
}
intranet-rest-v5-0-2-4-1/perl/get-project.perl 0000775 0000000 0000000 00000007126 13175625757 0021104 0 ustar 00root root 0000000 0000000 #!/usr/bin/perl -w
# --------------------------------------------------------
# get-project.perl
# (c) 2010 ]project-open[
# Frank Bergmann (frank.bergmann@project-open.com)
# Get the XML of the project with the specified ID
# --------------------------------------------------------
# Libraries
use XML::Parser;
use LWP::UserAgent;
# --------------------------------------------------------
# Connection parameters:
# Debug: 0=silent, 9=verbose
$debug = 1;
$rest_server = "http://demo.project-open.net"; # May include port number
$rest_email = "bbigboss\@tigerpond.com";
$rest_password = "ben";
# --------------------------------------------------------
# Expect the project_id as the command line argument
my $project_id = $ARGV[0];
if ("" eq $project_id) {
print "get-project.perl: Usage\n";
print "get-project.perl: \n";
print "get-project.perl: get-project.perl \n";
print "get-project.perl: \n";
exit 1;
}
# --------------------------------------------------------
# Get the XML for the project
$ua = LWP::UserAgent->new;
$req = HTTP::Request->new(GET => "$rest_server/intranet-rest/im_project/$project_id");
$req->authorization_basic($rest_email, $rest_password);
$response = $ua->request($req);
# Extract return_code (200, ...), headers and body from the response
print $response->as_string if ($debug > 8);
$code = $response->code if ($debug > 0);
print "list-projects.perl: HTTP return_code=$code\n" if ($debug > 0);
$headers = $response->headers_as_string;
print "list-projects.perl: HTTP headers=$headers\n" if ($debug > 7);
$body = $response->content;
print "list-projects.perl: HTTP body=$body\n" if ($debug > 8);
# -------------------------------------------------------
# Write the body into an XML file
open(F,"> $project_id.xml");
print F $body;
close(F);
# -------------------------------------------------------
# Creates a XML parser object with a number of event handlers
my $parser = new XML::Parser ( Handlers => {
Start => \&hdl_start,
End => \&hdl_end,
Char => \&hdl_char,
Default => \&hdl_def,
});
my $message; # Hashref containing infos on a message
$parser->parse($body); # Parse the message
# -------------------------------------------------------
# Define Event Handlers for event based XML parsing
# Handle the start of a tag.
# Store the tag's attributes into "message".
# Create a reserved field "_str" which will contain the strings of the tag.
sub hdl_start{
my ($p, $elt, %atts) = @_;
# return unless $elt eq 'object_id'; # We're only interrested in what's said
$atts{'var'} = $elt;
$atts{'_str'} = '';
$message = \%atts;
}
# Handle the end of a tag.
# Just print out the tag
sub hdl_end{
my ($p, $elt) = @_;
# return if $elt eq 'object_id' && $message && $message->{'_str'} =~ /\S/;
format_message($message);
}
# Handle characters: Append them to the "_str" field
sub hdl_char {
my ($p, $str) = @_;
$message->{'_str'} .= $str;
}
# Default handler: Just ignore everything else
sub hdl_def { }
# -------------------------------------------------------
# Helper sub to nicely format what we got from the XML
sub format_message {
my $atts = shift;
$atts->{'_str'} =~ s/\n//g;
if (!exists $atts->{'_str'}) { return; }
if (!exists $atts->{'var'}) { return; }
$str = $atts->{'_str'};
$var = $atts->{'var'};
print "list-projects.perl: $var=$str\n";
# while ( my ($key, $value) = each(%$atts) ) { print "$key => $value\n"; }
undef $message;
}
exit 0;
intranet-rest-v5-0-2-4-1/perl/list-conf-items.perl 0000775 0000000 0000000 00000023357 13175625757 0021702 0 ustar 00root root 0000000 0000000 #!/usr/bin/perl -w
# --------------------------------------------------------
# list-conf_items
# (c) 2010 ]project-open[
# Frank Bergmann (frank.bergmann@project-open.com)
#
# This Perl script will:
# 1. Create a connection to the REST server
# 2. Retreive the list of all ConfItems in the system
# 3. For every ConfItem:
# 3.1. Create a connection to the REST server
# 3.2. Retreive all fields of the ConfItem
# 3.3. Store the conf item values into a Hash of Hashes
# 4. End Loop
#
# --------------------------------------------------------
# Libraries
use XML::Parser;
use LWP::UserAgent;
# --------------------------------------------------------
# Connection parameters:
# Debug: 0=silent, 9=very verbose
$debug = 1;
# benbigboss/ben is a default user @ demo.project-open.net...
#
$rest_server = "http://demo.project-open.net"; # May include port number
$rest_email = "bbigboss\@tigerpond.com";
$rest_password = "ben";
# Work with local virtual machine
#
$rest_server = "http://192.168.21.128:30086"; # May include port number
# Global vars for keeping the current ID of the conf item and the list of conf items
my $conf_item_id;
my %list_conf_items = ();
# --------------------------------------------------------
# Request the list of configuration items
print "list-conf_items.perl: Sending HTTP request to $rest_server/intranet-rest/im_conf_item\n" if ($debug > 0);
print "list-conf_items.perl: Using email=$rest_email and password=$rest_password\n" if ($debug > 0);
$list_ua = LWP::UserAgent->new;
$list_req = HTTP::Request->new(GET => "$rest_server/intranet-rest/im_conf_item");
$list_req->authorization_basic($rest_email, $rest_password);
$list_response = $list_ua->request($list_req);
# Extract return_code (200, ...), headers and body from the response
print $list_response->as_string if ($debug > 8);
$code = $list_response->code if ($debug > 0);
print "list-conf_items.perl: HTTP return_code=$code\n" if ($debug > 0);
$headers = $list_response->headers_as_string;
print "list-conf_items.perl: HTTP headers=$headers\n" if ($debug > 7);
$body = $list_response->content;
print "list-conf_items.perl: HTTP body=$body\n" if ($debug > 8);
# -------------------------------------------------------
# Creates a XML parser object with a number of event handlers
# in order to parse the list of configuration items
my $list_parser = new XML::Parser ( Handlers => {
Start => \&list_hdl_start,
End => \&list_hdl_end,
Char => \&list_hdl_char,
Default => \&hdl_default,
});
my $list_message; # Hashref containing infos on a message
# Parse the message
# The parser will execute the list_hdl_* procedures which will
# continue the execution
$list_parser->parse($body); # Parse the message
# -------------------------------------------------------
# Define Event Handlers for handling the LIST of configuration items
# -------------------------------------------------------
# Default handler: Just ignore everything else
sub hdl_default { }
# Handle the start of a tag.
# Store the tag's attributes into "message".
# Create a reserved field "_str" which will contain the strings of the tag.
sub list_hdl_start{
my ($p, $elt, %list_atts) = @_;
return unless $elt eq 'object_id'; # We're only interrested in what's said
$list_atts{'_str'} = '';
$list_message = \%list_atts;
}
# Handle the end of a tag.
# Just print out the tag
sub list_hdl_end{
my ($p, $elt) = @_;
if ($elt eq 'object_id' && $list_message && $list_message->{'_str'} =~ /\S/) {
process_conf_item($list_message);
process_permissions($list_message);
}
}
# Handle characters: Append them to the "_str" field
sub list_hdl_char {
my ($p, $str) = @_;
$list_message->{'_str'} .= $str;
}
# -------------------------------------------------------
# Deal with a single configuration item returned from the list
# This procedure is called from the list_hdl_end when encountering
# an end-tag
# -------------------------------------------------------
sub process_conf_item {
my $list_atts = shift;
$list_atts->{'_str'} =~ s/\n//g;
$conf_item_name = $list_atts->{'_str'};
$conf_item_id = $list_atts->{'id'};
print "list-conf_items.perl: conf_item_id=$conf_item_id, conf_item_name=$conf_item_name\n";
# Show the other fields returned by the REST answer
# while ( my ($key, $value) = each(%$list_atts) ) { print "$key => $value\n"; }
# Get the XML for the project
$item_ua = LWP::UserAgent->new;
$item_req = HTTP::Request->new(GET => "$rest_server/intranet-rest/im_conf_item/$conf_item_id");
$item_req->authorization_basic($rest_email, $rest_password);
$item_response = $item_ua->request($item_req);
# Extract return_code (200, ...), headers and body from the response
print $item_response->as_string if ($debug > 8);
$code = $item_response->code if ($debug > 0);
print "list-conf-items.perl: HTTP return_code=$code\n" if ($debug > 0);
$headers = $item_response->headers_as_string;
print "list-conf-items.perl: HTTP headers=$headers\n" if ($debug > 7);
$body = $item_response->content;
print "list-conf-items.perl: HTTP body=$body\n" if ($debug > 8);
# -------------------------------------------------------
# Creates a XML parser object with a number of event handlers
my $item_parser = new XML::Parser ( Handlers => {
Start => \&item_hdl_start,
End => \&item_hdl_end,
Char => \&item_hdl_char,
Default => \&hdl_default,
});
my $item_message; # Hashref containing infos on a message
$item_parser->parse($body); # Parse the message
undef $item_message;
}
# Handle the start of a tag.
# Store the tag's attributes into "message".
# Create a reserved field "_str" which will contain the strings of the tag.
sub item_hdl_start{
my ($p, $elt, %item_atts) = @_;
# return unless $elt eq 'object_id'; # We're only interrested in what's said
$item_atts{'var'} = $elt;
$item_atts{'_str'} = '';
$item_message = \%item_atts;
}
# Handle characters: Append them to the "_str" field
sub item_hdl_char {
my ($p, $str) = @_;
$item_message->{'_str'} .= $str;
}
# Handle the end of a tag.
# Store the value into the $conf_item hash ref
sub item_hdl_end{
my ($p, $elt) = @_;
$item_message->{'_str'} =~ s/\n//g;
if (!exists $item_message->{'_str'}) { return; }
if (!exists $item_message->{'var'}) { return; }
$str = $item_message->{'_str'};
$var = $item_message->{'var'};
# Store the value into the $conf_item hash ref
print "list-conf-items.perl: id=$conf_item_id, $var=$str\n" if ($debug > 1);
if ("" ne $str) {
$list_conf_items{$conf_item_id}{$var} = $str;
}
undef $item_message;
}
# -------------------------------------------------------
# Retreive permissions for Conf Items
# -------------------------------------------------------
sub process_permissions {
my $list_atts = shift;
$list_atts->{'_str'} =~ s/\n//g;
$conf_item_name = $list_atts->{'_str'};
$conf_item_id = $list_atts->{'id'};
print "list-conf-items.perl: conf_item_id=$conf_item_id, conf_item_name=$conf_item_name\n";
# Get the XML for the project
$perm_ua = LWP::UserAgent->new;
$perm_req = HTTP::Request->new(GET => "$rest_server/intranet-rest/im_conf_item/$conf_item_id");
$perm_req->authorization_basic($rest_email, $rest_password);
$perm_response = $perm_ua->request($perm_req);
# Extract return_code (200, ...), headers and body from the response
print $perm_response->as_string if ($debug > 8);
$code = $perm_response->code if ($debug > 0);
print "list-conf-items.perl: HTTP return_code=$code\n" if ($debug > 0);
$headers = $perm_response->headers_as_string;
print "list-conf-items.perl: HTTP headers=$headers\n" if ($debug > 7);
$body = $perm_response->content;
print "list-conf-items.perl: HTTP body=$body\n" if ($debug > 8);
# -------------------------------------------------------
# Creates a XML parser object with a number of event handlers
my $perm_parser = new XML::Parser ( Handlers => {
Start => \&perm_hdl_start,
End => \&perm_hdl_end,
Char => \&perm_hdl_char,
Default => \&hdl_default,
});
my $perm_message; # Hashref containing infos on a message
$perm_parser->parse($body); # Parse the message
undef $perm_message;
}
# Handle the start of a tag.
# Store the tag's attributes into "message".
# Create a reserved field "_str" which will contain the strings of the tag.
sub perm_hdl_start{
my ($p, $elt, %perm_atts) = @_;
# return unless $elt eq 'object_id'; # We're only interrested in what's said
$perm_atts{'var'} = $elt;
$perm_atts{'_str'} = '';
$perm_message = \%perm_atts;
}
# Handle characters: Append them to the "_str" field
sub perm_hdl_char {
my ($p, $str) = @_;
$perm_message->{'_str'} .= $str;
}
# Handle the end of a tag.
# Store the value into the $conf_item hash ref
sub perm_hdl_end{
my ($p, $elt) = @_;
$perm_message->{'_str'} =~ s/\n//g;
if (!exists $perm_message->{'_str'}) { return; }
if (!exists $perm_message->{'var'}) { return; }
$str = $perm_message->{'_str'};
$var = $perm_message->{'var'};
# Store the value into the $conf_item hash ref
print "list-conf-items.perl: id=$conf_item_id, $var=$str\n" if ($debug > 1);
# if ("" ne $str) {
# $list_conf_items{$conf_item_id}{$var} = $str;
# }
undef $item_message;
}
# -------------------------------------------------------
# Print the list of configuration items
# -------------------------------------------------------
# Print out the "list_conf_items" Hash of Hashes
sub print_conf_items {
for $cid (keys %list_conf_items) {
print "conf_item_id=$cid: \n";
for $attrib (keys %{$list_conf_items{$cid}}) {
print "\t$attrib = $list_conf_items{$cid}{$attrib} \n";
}
print "\n";
}
}
print_conf_items();
exit 0;
intranet-rest-v5-0-2-4-1/perl/list-projects.perl 0000664 0000000 0000000 00000004212 13175625757 0021451 0 ustar 00root root 0000000 0000000 #!/usr/bin/perl -w
# --------------------------------------------------------
# list-projects
#
# (c) 2010-2014 ]project-open[
# Frank Bergmann (frank.bergmann@project-open.com)
#
# Example for accessing the ]po[ REST API V3 using
# Perl and HTTP basic authentication
# --------------------------------------------------------
# --------------------------------------------------------
# Libraries
#
use strict;
use LWP::UserAgent;
use Data::Dumper;
use JSON;
# --------------------------------------------------------
# Connection parameters:
#
my $debug = 1; # Debug: 0=silent, 9=verbose
my $rest_server = "http://demo.project-open.net"; # May include port number, but no trailing "/"
my $rest_email = "bbigboss\@tigerpond.com"; # Email for basic authentication
my $rest_password = "ben"; # Password for basic authentication
#my $rest_server = "http://localhost:8000"; # May include port number
# --------------------------------------------------------
# Request the result
#
print "list-projects.perl: Sending HTTP request to $rest_server/intranet-rest/im_project\n" if ($debug > 0);
print "list-projects.perl: Using email=$rest_email and password=$rest_password\n" if ($debug > 0);
my $ua = LWP::UserAgent->new;
my $url = "$rest_server/intranet-rest/im_project?format=json";
my $req = HTTP::Request->new(GET => $url);
$req->authorization_basic($rest_email, $rest_password);
my $response = $ua->request($req);
my $body = $response->content;
print "list-projects.perl: HTTP body=$body\n" if ($debug > 8);
# -------------------------------------------------------
# Check and parse JSON results
#
my $return_code = $response->code;
my $json = decode_json($body);
my $success = $json->{'success'};
my $total = $json->{'total'};
my $message = $json->{'message'};
print "list-projects.perl: return_code=$return_code, success=$success, total=$total, message=$message\n";
print Dumper $json if ($debug > 5);
# -------------------------------------------------------
# List projects
#
my @projects = @{$json->{'data'}};
foreach my $p (@projects) {
print "project_id=" . $p->{'project_id'} . ", project_name=" . $p->{'project_name'} . "\n";
}
exit 0;
intranet-rest-v5-0-2-4-1/perl/test-list.perl 0000664 0000000 0000000 00000010134 13175625757 0020577 0 ustar 00root root 0000000 0000000 #!/usr/bin/perl -w
# --------------------------------------------------------
# test-list.perl
#
# (c) 2014 ]project-open[
# Frank Bergmann (frank.bergmann@project-open.com)
#
# Tests the REST "list" operation for all object types
# --------------------------------------------------------
# --------------------------------------------------------
# Libraries
#
use strict;
use LWP::UserAgent;
use Data::Dumper;
use JSON;
use Getopt::Long;
# BEGIN {push @INC, '../../intranet-rest/perl'}
use ProjectOpen;
# --------------------------------------------------------
# Connection parameters:
#
my $debug = 0; # Debug: 0=silent, 9=verbose
my $rest_host = "demo.project-open.net"; # May include port number, but no trailing "/"
my $rest_email = "bbigboss\@tigerpond.com"; # Email for basic authentication
my $rest_password = "ben"; # Password for basic authentication
$rest_host = "localhost:8000";
my $result = GetOptions (
"debug=i" => \$debug,
"host=s" => \$rest_host,
"email=s" => \$rest_email,
"password=s" => \$rest_password
) or die "Usage:\n\ntest-list.perl --debug 1 --host localhost:8000 --email bbigboss\@tigerpond.com --password ben\n\n";
# --------------------------------------------------------
# Request the result
#
my $ua = LWP::UserAgent->new;
my $url = "http://$rest_host/intranet-rest/index?format=json";
my $req = HTTP::Request->new(GET => $url);
$req->authorization_basic($rest_email, $rest_password);
my $response = $ua->request($req);
my $body = $response->content;
print "test-list.perl: HTTP body=$body\n" if ($debug > 8);
# -------------------------------------------------------
# Check and parse JSON results
#
my $return_code = $response->code;
if (200 != $return_code) {
print "test-list.perl: list all object types 0 $url return_code=$return_code, message=$body\n";
exit 1;
}
my $json;
eval {
$json = decode_json($body);
};
if ($@) {
print "test-list.perl: list all object types 0 $url Failed to parse JSON, json=$body\n";
exit 1;
}
my $success = $json->{'success'};
my $total = $json->{'total'};
my $message = $json->{'message'};
my $successfull_p = ($return_code eq "200") && ($success eq "true") && ($total > 50);
if (!$successfull_p || $debug > 0) {
print "test-list.perl: list all object types $successfull_p $url return_code=$return_code, success=$success, total=$total, message=$message\n";
}
# --------------------------------------------------------
# Create a generic access object to query the ]po[ HTTP server
#
ProjectOpen->new (
host => $rest_host,
email => $rest_email,
password => $rest_password,
debug => $debug
);
# -------------------------------------------------------
# List object_types
#
my @object_types = @{$json->{'data'}};
foreach my $ot (@object_types) {
my $object_type = $ot->{'object_type'};
my $pretty_name = $ot->{'pretty_name'};
next if ($object_type =~ /::/);
# next if ($object_type =~ /acs_message_revision/); # throws hard error in client
# next if ($object_type ne "im_trans_task");
$url = "http://$rest_host/intranet-rest/$object_type?format=json";
print STDERR "test-list.perl: getting objects of type $object_type from $url\n" if ($debug > 0);
my $object_json = ProjectOpen->get_object_list($object_type);
if (ref($object_json) ne "HASH") {
print "test-list.perl: list $object_type 0 $url Internal error in get_object_list\n";
next;
}
my $success = $object_json->{'success'};
my $message = $object_json->{'message'};
$message =~ tr/\n\t/ /;
my $short_msg = substr($message, 0, 40);
if ("true" ne $success) {
print "test-list.perl: list $object_type 0 $url $short_msg\n";
next;
}
my $total = $object_json->{'total'};
if (!defined $total) {
print "test-list.perl: list $object_type 0 $url Result does not contain 'total' property\n";
next;
}
my @object_list = @{$object_json->{'data'}};
$successfull_p = ($success eq "true");
if (!$successfull_p || $debug > 0) {
print "test-list.perl: list $object_type $successfull_p $url success=$success, total=$total, message=$short_msg\n";
}
}
exit 0;
intranet-rest-v5-0-2-4-1/perl/test-new-delete.perl 0000775 0000000 0000000 00000020602 13175625757 0021661 0 ustar 00root root 0000000 0000000 #!/usr/bin/perl -w
# --------------------------------------------------------
# test-new-delete.perl
#
# (c) 2014 ]project-open[
# Frank Bergmann (frank.bergmann@project-open.com)
#
# Tests the REST "update" operation for all object types
# --------------------------------------------------------
# --------------------------------------------------------
# Libraries
#
use strict;
use LWP::UserAgent;
use Data::Dumper;
use JSON;
use Getopt::Long;
# BEGIN {push @INC, '../../intranet-rest/perl'}
use ProjectOpen;
# --------------------------------------------------------
# Parameters:
#
my $debug = 0; # Debug: 0=silent, 9=verbose
my $rest_host = "demo.project-open.net"; # May include port number, but no trailing "/"
my $rest_email = "sysadmin\@tigerpond.com"; # Email for basic auth, needs to be Admin
my $rest_password = "system"; # Password for basic authentication
$rest_host = "localhost:8000";
my $result = GetOptions (
"debug=i" => \$debug,
"host=s" => \$rest_host,
"email=s" => \$rest_email,
"password=s" => \$rest_password
) or die "Usage:\n\ntest-new-delete.perl --debug 1 --host localhost:8000 --email bbigboss\@tigerpond.com --password ben\n\n";
# --------------------------------------------------------
# Create a generic access object to query the ]po[ HTTP server
#
ProjectOpen->new (
host => $rest_host,
email => $rest_email,
password => $rest_password,
debug => $debug
);
# --------------------------------------------------------
# Map of object types into their name fields
#
# A random name for the new object
my $r = "" . int(1000000000.0 * rand() * 1000000000.0);
# The ID of the SysAdmin - he's the first user in the system after 0=Guest
my $sysadmin_hash = ProjectOpen->get_object_list("user", "user_id in (select min(user_id) from users where user_id > 0)");
my $sysadmin_id = $sysadmin_hash->{'data'}[0]{'user_id'};
# The ID of a customer and a provider company
my $customer_hash = ProjectOpen->get_object_list("im_company", "company_type_id = 57");
my $customer_id = $customer_hash->{'data'}[0]{'user_id'};
my $provider_hash = ProjectOpen->get_object_list("im_company", "company_type_id = 57");
my $provider_id = $provider_hash->{'data'}[0]{'user_id'};
# A container for creating tickets
my $sla_hash = ProjectOpen->get_object_list("im_project", "project_type_id = 2502");
my $sla_id = $sla_hash->{'data'}[0]{'project_id'};
my $constructors_hash = {
"im_company" => {"company_name" => $r, "company_path" => $r, "company_status_id" => 46,
"company_type_id" => 57},
"im_project" => {"project_name" => "Project #$r", "project_nr" => "project_$r",
"project_status_id" => 76, "project_type_id" => 2501},
"im_office" => {"office_name" => $r, "office_path" => $r, "office_status_id" => 160,
"office_type_id" => 160},
"im_ticket" => {"project_name" => "Ticket #$r", "parent_id" => $sla_id},
"im_user_absence" => {"absence_name" => "Absence #$r", "duration_days" => 2, "owner_id" => $sysadmin_id,
"start_date" => "2014-11-01", "end_date" => "2014-11-05",
"description" => "Halloween", "absence_type_id" => 5000, "absence_status_id" => 16000},
"im_hour" => {"user_id" => $sysadmin_id, "project_id" => $sla_id, "day" => "2014-11-01",
"hours" => "1.23", "note" => $r},
"im_note" => {"note" => $r, "object_id" => $sla_id, "note_status_id" => 11400,
"note_type_id" => 11400},
"im_expense" => {"cost_name" => "Expense #$r", "cost_nr=" => "cost_$r", "customer_id" => $customer_id,
"provider_id" => $provider_id, "cost_status_id" => 3802, "cost_type_id" => 3720,
"effective_date" => "2014-11-11", "amount" => "123.45", "currency" => "EUR",
"external_company_name" => "External Company #$r"}
};
my $ttt = {
"im_expense_bundle" => "cost_name",
"im_hour_interval" => "note",
"im_forum_topic" => "topic_name",
"im_fs_file" => "filename",
"im_indicator" => "report_name",
"im_invoice" => "cost_name",
"im_invoice_item" => "item_name",
"im_risk" => "risk_name",
"im_timesheet_conf_object" => "comment",
"im_timesheet_task" => "project_name",
};
# --------------------------------------------------------
# Request the result
#
my $ua = LWP::UserAgent->new;
my $url = "http://$rest_host/intranet-rest/index?format=json";
my $req = HTTP::Request->new(GET => $url);
$req->authorization_basic($rest_email, $rest_password);
my $response = $ua->request($req);
my $body = $response->content;
print STDERR "test-new-delete.perl: HTTP body=$body\n" if ($debug > 8);
my $return_code = $response->code;
if (200 != $return_code) {
print "test-new-delete.perl: list all object types 0 $url return_code=$return_code, message=$body\n";
exit 1;
}
my $json;
eval { $json = decode_json($body); };
if ($@) {
print "test-new-delete.perl: list all object types 0 $url Failed to parse JSON, json=$body\n";
exit 1;
}
my $success = $json->{'success'};
my $total = $json->{'total'};
my $message = $json->{'message'};
my $successfull_p = ($return_code eq "200") && ($success eq "true") && ($total > 50);
if (!$successfull_p || $debug > 1) {
print "test-new-delete.perl: list all object types $successfull_p $url return_code=$return_code, success=$success, total=$total, message=$message\n";
}
# -------------------------------------------------------
# Loop for all object types
#
my @object_types = @{$json->{'data'}};
foreach my $ot (@object_types) {
my $object_type = $ot->{'object_type'};
my $pretty_name = $ot->{'pretty_name'};
next if ($object_type =~ /::/);
# next if ($object_type =~ /acs_message_revision/); # throws hard error in client
# next if ($object_type ne "im_cost_center");
# next if (!($object_type =~ /^im_ticket$/));
# -------------------------------
# Check if we have defined a constructor
#
my $constructor_hash;
if (exists $constructors_hash->{$object_type}) {
$constructor_hash = $constructors_hash->{$object_type};
print STDERR "test-new-delete.perl: $object_type: constructor=" . Dumper($constructor_hash) . "\n" if ($debug > 0);
} else {
print STDERR "test-new-delete.perl: $object_type: no constructor defined - skipping\n" if ($debug > 4);
next;
}
# -------------------------------------------------------
# Create a new object
#
my $url = "http://$rest_host/intranet-rest/$object_type";
print STDERR "test-new-delete.perl: $object_type: Creating a new object\n" if ($debug > 1);
my $result_hash = ProjectOpen->_http_post_request($url, $constructor_hash);
$success = $result_hash->{'success'};
$message = $result_hash->{'message'};
my $object_hash = $result_hash->{'data'}[0];
my $oid = $object_hash->{'object_id'};
if (($success eq "true") && ($oid eq int($oid))) { $successfull_p = 1 } else { $successfull_p = 0; }
if (!$successfull_p || $debug > 0) {
print STDERR "test-new-delete.perl: ID of new object: " . Dumper($oid). "\n" if ($debug > 6);
print "test-new-delete.perl: create new $object_type $successfull_p $url success=$success, message=$message\n";
}
next if (!$successfull_p);
# -------------------------------------------------------
# Get the object that we've just created
#
print STDERR "test-new-delete.perl: $object_type: Getting single object with OID=$oid\n" if ($debug > 1);
$result_hash = ProjectOpen->get_object($object_type, $oid);
$success = $result_hash->{'success'};
$message = $result_hash->{'message'};
$object_hash = $result_hash->{'data'}[0];
if ($success eq "true") { $successfull_p = 1 } else { $successfull_p = 0; }
if (!$successfull_p || $debug > 0) {
print "test-new-delete.perl: check for newly created $object_type $successfull_p $url success=$success, message=$message\n";
}
# -------------------------------------------------------
# Delete the object that we've just created
#
$url = "http://$rest_host/intranet-rest/$object_type/$oid";
print STDERR "test-new-delete.perl: $object_type: Deleting $object_type: #".$oid."\n" if ($debug > 1);
$result_hash = ProjectOpen->_http_delete_request($url);
$success = $result_hash->{'success'};
$message = $result_hash->{'message'};
if ($success eq "true") { $successfull_p = 1 } else { $successfull_p = 0; }
if (!$successfull_p || $debug > 0) {
print "test-new-delete.perl: delete $object_type $successfull_p $url success=$success, message=$message\n";
}
next if (!$successfull_p);
}
exit 0;
intranet-rest-v5-0-2-4-1/perl/test-update.perl 0000664 0000000 0000000 00000024757 13175625757 0021126 0 ustar 00root root 0000000 0000000 #!/usr/bin/perl -w
# --------------------------------------------------------
# test-update.perl
#
# (c) 2014 ]project-open[
# Frank Bergmann (frank.bergmann@project-open.com)
#
# Tests the REST "update" operation for all object types
# --------------------------------------------------------
# --------------------------------------------------------
# Libraries
#
use strict;
use LWP::UserAgent;
use Data::Dumper;
use JSON;
use Getopt::Long;
# BEGIN {push @INC, '../../intranet-rest/perl'}
use ProjectOpen;
# --------------------------------------------------------
# Parameters:
#
my $debug = 1; # Debug: 0=silent, 9=verbose
my $rest_host = "demo.project-open.net"; # May include port number, but no trailing "/"
my $rest_email = "sysadmin\@tigerpond.com"; # Email for basic auth, needs to be Admin
my $rest_password = "system"; # Password for basic authentication
$rest_host = "localhost:8000";
my $result = GetOptions (
"debug=i" => \$debug,
"host=s" => \$rest_host,
"email=s" => \$rest_email,
"password=s" => \$rest_password
) or die "Usage:\n\ntest-update.perl --debug 1 --host localhost:8000 --email bbigboss\@tigerpond.com --password ben\n\n";
# --------------------------------------------------------
# Map of object types into their name fields
#
my $object_type_name_field_hash = {
"im_category" => "category",
"im_company" => "company_name",
"im_conf_item" => "conf_item_name",
"im_cost" => "cost_name",
"im_cost_center" => "cost_center_name",
"im_dynfield_attribute" => "attribute_name",
"im_dynfield_widget" => "widget_name",
"im_expense" => "cost_name",
"im_expense_bundle" => "cost_name",
"im_forum_topic" => "topic_name",
"im_fs_file" => "filename",
"im_hour" => "note",
"im_indicator" => "report_name",
"im_invoice" => "cost_name",
"im_invoice_item" => "item_name",
"im_material" => "material_name",
"im_menu" => "name",
"im_note" => "note",
"im_office" => "office_name",
"im_project" => "project_name",
"im_report" => "report_name",
"im_risk" => "risk_name",
"im_ticket" => "project_name",
"im_ticket_queue" => "group_name",
"im_timesheet_conf_object" => "comment",
"im_timesheet_invoice" => "cost_name",
"im_timesheet_task" => "project_name",
"im_user_absence" => "absence_name"
};
# --------------------------------------------------------
# Request the result
#
my $ua = LWP::UserAgent->new;
my $url = "http://$rest_host/intranet-rest/index?format=json";
my $req = HTTP::Request->new(GET => $url);
$req->authorization_basic($rest_email, $rest_password);
my $response = $ua->request($req);
my $body = $response->content;
print STDERR "test-update.perl: HTTP body=$body\n" if ($debug > 8);
# -------------------------------------------------------
# Check and parse the list of object type
#
my $return_code = $response->code;
if (200 != $return_code) {
print "test-update.perl: update all object types 0 $url return_code=$return_code, message=$body\n";
exit 1;
}
my $json;
eval { $json = decode_json($body); };
if ($@) {
print "test-update.perl: update all object types 0 $url Failed to parse JSON, json=$body\n";
exit 1;
}
my $success = $json->{'success'};
my $total = $json->{'total'};
if (!defined $total) { $total = 0; }
my $successfull_p = ($return_code eq "200") && ($success eq "true" || $success eq "1") && ($total > 50);
my $message = $json->{'message'};
if (!$successfull_p || $debug > 1) {
print "test-update.perl: list all object types '$successfull_p' $url return_code=$return_code, success=$success, total=$total, message=$message\n";
}
if (!$successfull_p) {
die "test-update.perl:\tError getting the list of objects - aborting\n";
}
# --------------------------------------------------------
# Create a generic access object to query the ]po[ HTTP server
#
ProjectOpen->new (
host => $rest_host,
email => $rest_email,
password => $rest_password,
debug => 0
);
# -------------------------------------------------------
# Loop for all object types
#
my @object_types = @{$json->{'data'}};
foreach my $ot (@object_types) {
my $object_type = $ot->{'object_type'};
my $pretty_name = $ot->{'pretty_name'};
next if ($object_type =~ /::/);
# next if ($object_type =~ /acs_message_revision/); # throws hard error in client
# next if ($object_type ne "im_cost_center");
# next if (!($object_type =~ /^im_/));
# ----------------------------------------
# Get the list of objects for the object type
# and check return codes
$url = "http://$rest_host/intranet-rest/$object_type?format=json";
print STDERR "test-update.perl: $object_type\n" if ($debug > 1);
print STDERR "test-update.perl: $object_type\n" if ($debug > 1);
print STDERR "test-update.perl: $object_type: Getting list of $object_type from $url\n" if ($debug > 1);
my $object_json = ProjectOpen->get_object_list($object_type);
if (ref($object_json) ne "HASH") {
print "test-update.perl: update $object_type 0 $url Internal error in get_object_update\n";
next;
}
my $success = $object_json->{'success'};
my $message = $object_json->{'message'};
$message =~ tr/\n\t/ /;
my $short_msg = substr($message, 0, 40);
if ("true" ne $success && "1" ne $success) {
print "test-update.perl: list $object_type 0 $url $short_msg\n";
next;
}
$total = $object_json->{'total'};
if (0 == $total) {
# No objects found of the specific type
print STDERR "test-update.perl: $object_type: Didn't find any objects of this type\n" if ($debug > 1);
next;
}
my @object_list_json = @{$object_json->{'data'}};
print STDERR "test-update.perl: $object_type: List of objects of type $object_type: " . Dumper(@object_list_json) . "\n" if ($debug > 8);
my $first_object_json = $object_list_json[0];
print STDERR "test-update.perl: $object_type: JSON of first object of type $object_type: " . Dumper($first_object_json) . "\n" if ($debug > 8);
my $oid = $first_object_json->{'id'}; # Every REST results includes a generic 'id'
if (!defined $oid) {
print "test-update.perl: list $object_type 0 $url Didn't find 'id' property of first object\n";
next;
}
print "test-update.perl: list $object_type 1 $url $short_msg\n" if ($debug > 0);
# -------------------------------
# Test the single object GET request
#
print STDERR "test-update.perl: $object_type: Getting single object with OID=$oid\n" if ($debug > 1);
my $get_object_json = ProjectOpen->get_object($object_type, $oid);
my $object_data_json = $get_object_json->{'data'}[0];
print STDERR "test-update.perl: $object_type: get_object($object_type,$oid): " . Dumper($object_data_json) . "\n" if ($debug > 6);
$success = $get_object_json->{'success'};
$message = $get_object_json->{'message'};
$message =~ tr/\n\t/ /;
$short_msg = substr($message, 0, 40);
if ("true" ne $success && "1" ne $success) {
$url = "http://$rest_host/intranet-rest/$object_type/$oid?format=json";
print "test-update.perl: get $oid 0 $url $short_msg\n";
next;
}
# -------------------------------
# Update object using REST with exactly the same data.
# This tests that there is no error message during update.
#
print STDERR "test-update.perl: $object_type: Updating object OID=$oid with identical data:\n" if ($debug > 1);
my $update_result = ProjectOpen->post_object($object_type, $oid, $object_data_json);
print STDERR "test-update.perl: $object_type: post_object: result=" . Dumper($update_result) . "\n" if ($debug > 4);
# ToDo: Write out error message in case of failure
# -------------------------------
# Check if we know the name field of the object type
#
my $name_field = "";
if (exists $object_type_name_field_hash->{$object_type}) {
$name_field = $object_type_name_field_hash->{$object_type};
print STDERR "test-update.perl: $object_type: name_field=" . $name_field . " for object_type=" . $object_type . "\n" if ($debug > 4);
} else {
print STDERR "test-update.perl: $object_type: no name_field exists for object_type=" . $object_type . "\n" if ($debug > 4);
next;
}
# -------------------------------
# We know the name field of the object type.
# Let's append a "%" at the end of the name and
# check that the object was updated correctly.
#
print STDERR "test-update.perl: $object_type: Appended a '%' to name_field=$name_field of object #$oid\n" if ($debug > 1);
my $object_name = $object_data_json->{$name_field};
if (!defined $object_name) {
print "test-update.perl: get object_name for $object_type 0 unknown url Didn't find '$name_field' property in object_data_json of #$oid\n";
next;
}
$object_data_json->{$name_field} = $object_name . "%";
print STDERR "test-update.perl: $object_type: post_object: data=" . Dumper($object_data_json) . "\n" if ($debug > 8);
$update_result = ProjectOpen->post_object($object_type, $oid, $object_data_json);
print STDERR "test-update.perl: $object_type: post_object: result=" . Dumper($update_result) . "\n" if ($debug > 6);
# ToDo: Write out error message in case of failure
# -------------------------------
# Get the updated data
#
print STDERR "test-update.perl: $object_type: Get the object #$oid ('$object_name') and check if the '%' was successfully written\n" if ($debug > 1);
$get_object_json = ProjectOpen->get_object($object_type, $oid);
$object_data_json = $get_object_json->{'data'}[0];
$success = $get_object_json->{'success'};
$message = $get_object_json->{'message'};
$message =~ tr/\n\t/ /;
$short_msg = substr($message, 0, 40);
if ("true" ne $success && "1" ne $success) {
print "test-update.perl: get $oid 0 $url $short_msg\n";
next;
}
# Compare the new name of the object
my $new_object_name = $object_data_json->{$name_field};
if ($new_object_name ne $object_name . "%") {
print "test-update.perl: get updated name of $oid 0 $url update of object name failed: org=$object_name, new=$new_object_name\n";
}
# -------------------------------
# Restore the original data
#
print STDERR "test-update.perl: $object_type: Restore the original values of object #$oid\n" if ($debug > 1);
$object_data_json->{$name_field} = $object_name;
$update_result = ProjectOpen->post_object($object_type, $oid, $object_data_json);
print STDERR "test-update.perl: $object_type: post_object: result=" . Dumper($update_result) . "\n" if ($debug > 6);
# ToDo: Write out error message in case of failure
}
exit 0;
intranet-rest-v5-0-2-4-1/sql/ 0000775 0000000 0000000 00000000000 13175625757 0015621 5 ustar 00root root 0000000 0000000 intranet-rest-v5-0-2-4-1/sql/postgresql/ 0000775 0000000 0000000 00000000000 13175625757 0020024 5 ustar 00root root 0000000 0000000 intranet-rest-v5-0-2-4-1/sql/postgresql/intranet-rest-create.sql 0000775 0000000 0000000 00000045675 13175625757 0024631 0 ustar 00root root 0000000 0000000 -- /packages/intranet-rest/sql/postgresql/intranet-rest-create.sql
--
-- Copyright (c) 2003-2007 ]project-open[
--
-- All rights reserved. Please check
-- http://www.project-open.com/license/ for details.
--
-- @author frank.bergmann@project-open.com
-----------------------------------------------------------
-- REST
--
-- We need an "im_rest_object_type" object for every acs_object_type
-- to define permissions per object type
-- Create a new object type.
-- This statement only creates an entry in acs_object_types with some
-- meta-information (table name, ... as specified below) about the new
-- object.
-- Please note that this is quite different from creating a new object
-- class in Java or other languages.
SELECT acs_object_type__create_type (
'im_rest_object_type', -- object_type - only lower case letters and "_"
'REST Object Type', -- pretty_name - Human readable name
'REST Object Types', -- pretty_plural - Human readable plural
'acs_object', -- supertype - "acs_object" is topmost object type.
'im_rest_object_types', -- table_name - where to store data for this object?
'object_type_id', -- id_column - where to store object_id in the table?
'intranet-rest', -- package_name - name of this package
'f', -- abstract_p - abstract class or not
null, -- type_extension_table
'im_rest_object_type__name' -- name_method - a PL/SQL procedure that
-- returns the name of the object.
);
-- Add additional meta information to allow DynFields to extend the im_rest_object_type object.
update acs_object_types set
status_type_table = 'im_rest_object_types', -- which table contains the status_id field?
status_column = 'object_type_status_id', -- which column contains the status_id field?
type_column = 'object_type_type_id' -- which column contains the type_id field?
where object_type = 'im_rest_object_type';
-- Object Type Tables contain the lists of all tables (except for
-- acs_objects...) that contain information about an im_rest_object_type object.
-- This way, developers can add "extension tables" to an object to
-- hold additional DynFields, without changing the program code.
insert into acs_object_type_tables (object_type,table_name,id_column)
values ('im_rest_object_type', 'im_rest_object_types', 'object_type_id');
-- Generic URLs to link to an object of type "im_rest_object_type".
-- These URLs are used by the Full-Text Search Engine and the Workflow
-- to show links to the object type.
insert into im_biz_object_urls (object_type, url_type, url) values (
'im_rest_object_type','view','/intranet-rest/new?display_mode=display&object_type_id=');
insert into im_biz_object_urls (object_type, url_type, url) values (
'im_rest_object_type','edit','/intranet-rest/new?display_mode=edit&object_type_id=');
-- This table stores one object per row. Links to super-type "acs_object"
-- using the "object_type_id" field, which contains the same object_id as
-- acs_objects.object_id.
create table im_rest_object_types (
-- The object_id: references acs_objects.object_id.
-- So we can lookup object metadata such as creation_date,
-- object_type etc in acs_objects.
object_type_id integer
constraint im_rest_object_type_id_pk
primary key
constraint im_rest_object_type_id_fk
references acs_objects,
-- Every ]po[ object should have a "status_id" to control
-- its lifecycle. Status_id reference im_categories, where
-- you can define the list of stati for this object type.
object_type_status_id integer
constraint im_rest_object_type_status_nn
not null
constraint im_rest_object_type_status_fk
references im_categories,
-- Every ]po[ object should have a "type_id" to allow creating
-- sub-types of the object. Type_id references im_categories
-- where you can define the list of subtypes per object type.
object_type_type_id integer
constraint im_rest_object_type_type_nn
not null
constraint im_rest_object_type_type_fk
references im_categories,
-- This is the main content of a "object_type". Just a piece of text.
object_type varchar (1000)
constraint im_rest_object_type_object_type_nn
not null
constraint im_rest_object_type_object_type_fk
references acs_object_types
);
-- Speed up (frequent) queries to find all rest for a specific object.
create index im_rest_object_types_object_type_idx on im_rest_object_types(object_type);
-- Avoid duplicate entries.
-- Every ]po[ object should contain one such "unique" constraint.
create unique index im_rest_object_object_type_idx on im_rest_object_types(object_type);
-----------------------------------------------------------
-- PL/SQL functions to Create and Delete rest and to get
-- the name of a specific object_type.
--
-- These functions represent constructor/destructor
-- functions for the OpenACS object system.
-- The double underscore ("__") represents the dot ("."),
-- which is not allowed in PostgreSQL.
-- Get the name for a specific object_type.
-- This function allows displaying object in generic contexts
-- such as the Full-Text Search engine or the Workflow.
--
-- Input is the object_type_id, output is a string with the name.
-- The function just pulls out the "object_type" text of the object_type
-- as the name. Not pretty, but we don't have any other data,
-- and every object needs this "__name" function.
create or replace function im_rest_object_type__name(integer)
returns varchar as '
DECLARE
p_object_type_id alias for $1;
v_name varchar;
BEGIN
select object_type
into v_name
from im_rest_object_types
where object_type_id = p_object_type_id;
return v_name;
end;' language 'plpgsql';
-- Create a new object_type.
-- The first 6 parameters are common for all ]po[ business objects
-- with metadata such as the creation_user etc. Context_id
-- is always disabled (NULL) for ]po[ objects (inherit permissions
-- from a super object...).
-- The following parameters specify the content of a object_type with
-- the required fields of the im_rest table.
create or replace function im_rest_object_type__new (
integer, varchar, timestamptz,
integer, varchar, integer,
varchar, integer,
integer
) returns integer as '
DECLARE
-- Default 6 parameters that go into the acs_objects table
p_object_type_id alias for $1; -- object_type_id default null
p_object_type alias for $2; -- object_type default ''im_rest_object_type''
p_creation_date alias for $3; -- creation_date default now()
p_creation_user alias for $4; -- creation_user default null
p_creation_ip alias for $5; -- creation_ip default null
p_context_id alias for $6; -- context_id default null
-- Specific parameters with data to go into the im_rest_object_types table
p_rest_object_type alias for $7; -- im_rest.note - contents
p_object_type_status_id alias for $8; --
p_object_type_type_id alias for $9; --
-- This is a variable for the PL/SQL function
v_object_type_id integer;
BEGIN
-- Create an acs_object as the super-type of the object_type.
-- (Do you remember, im_rest_object_type is a subtype of acs_object?)
-- acs_object__new returns the object_id of the new object.
v_object_type_id := acs_object__new (
p_object_type_id, -- object_id - NULL to create a new id
p_object_type, -- object_type - "im_rest_object_type"
p_creation_date, -- creation_date - now()
p_creation_user, -- creation_user - Current user or "0" for guest
p_creation_ip, -- creation_ip - IP from ns_conn, or "0.0.0.0"
p_context_id, -- context_id - NULL, not used in ]po[
''t'' -- security_inherit_p - not used in ]po[
);
-- Create an entry in the im_rest table with the same
-- v_object_type_id from acs_objects.object_id
insert into im_rest_object_types (
object_type_id,
object_type_status_id,
object_type_type_id,
object_type
) values (
v_object_type_id,
coalesce(p_object_type_status_id, 43000),
coalesce(p_object_type_type_id, 43100),
p_rest_object_type
);
return v_object_type_id;
END;' language 'plpgsql';
-- Delete a object_type from the system.
-- Delete entries from both im_rest and acs_objects.
-- Deleting only from im_rest would lead to an invalid
-- entry in acs_objects, which is probably harmless, but innecessary.
create or replace function im_rest_object_type__delete(integer)
returns integer as '
DECLARE
p_object_type_id alias for $1;
BEGIN
-- Delete any data related to the object
delete from im_rest_object_types
where object_type_id = p_object_type_id;
-- Finally delete the object iself
PERFORM acs_object__delete(p_object_type_id);
return 0;
end;' language 'plpgsql';
-----------------------------------------------------------
-- Categories for Type and Status
--
-- Create categories for REST type and status.
-- Status acutally is not used by the application,
-- so we just define "active" and "deleted".
-- Type contains information on how to format the data
-- in the im_rest.object_type field. For example, a "HTTP"
-- object_type is shown as a link.
--
-- The categoriy_ids for status and type are used as a
-- global unique constants and defined in
-- /packages/intranet-core/sql/common/intranet-categories.sql.
-- Please send an email to support@project-open.com with
-- the subject line "Category Range Request" in order to
-- request a range of constants for your own modules.
--
-- 43000-43999 Reserved for Intranet REST
-- 43000-43099 Intranet REST Status
-- 43100-43199 Intranet REST Type
-- Status
SELECT im_category_new (43000, 'Active', 'Intranet REST Object Type Status');
-- Type
SELECT im_category_new (43100, 'Default', 'Intranet REST Object Type Type');
-----------------------------------------------------------
-- Create views for shortcut
--
-- These views are optional.
create or replace view im_rest_object_type_status as
select category_id as object_type_status_id, category as object_type_status
from im_categories
where category_type = 'Intranet REST Object Type Status'
and enabled_p = 't';
create or replace view im_rest_object_type_types as
select category_id as object_type_type_id, category as object_type_type
from im_categories
where category_type = 'Intranet REST Object Type Type'
and enabled_p = 't';
-----------------------------------------------------------
-- Menu for REST
--
-- Create a menu item in the main menu bar and set some default
-- permissions for various groups who should be able to see the menu.
create or replace function inline_0 ()
returns integer as '
declare
-- Menu IDs
v_menu integer;
v_admin_menu integer;
BEGIN
-- Determine the main menu. "Label" is used to
-- identify menus.
select menu_id into v_admin_menu
from im_menus where label=''admin'';
-- Create the menu.
v_menu := im_menu__new (
null, -- p_menu_id
''im_menu'', -- object_type
now(), -- creation_date
null, -- creation_user
null, -- creation_ip
null, -- context_id
''intranet-rest'', -- package_name
''admin_rest'', -- label
''REST API'', -- name
''/intranet-rest/'', -- url
2200, -- sort_order
v_admin_menu, -- parent_menu_id
null -- p_visible_tcl
);
return 0;
end;' language 'plpgsql';
-- Execute and then drop the function
select inline_0 ();
drop function inline_0 ();
update im_menus set menu_gif_small = 'arrow_right'
where label = 'admin_rest';
-----------------------------------------------------------
-- Create a new Report category for REST reports
--
create or replace function inline_0 ()
returns integer as '
declare
-- Menu IDs
v_menu integer;
v_reporting_menu integer;
BEGIN
-- Determine the main menu. "Label" is used to
-- identify menus.
select menu_id into v_reporting_menu
from im_menus where label=''reporting'';
-- Create the menu.
v_menu := im_menu__new (
null, -- p_menu_id
''im_menu'', -- object_type
now(), -- creation_date
null, -- creation_user
null, -- creation_ip
null, -- context_id
''intranet-rest'', -- package_name
''reporting-rest'', -- label
''REST System Reports'', -- name
''/intranet-reporting/'', -- url
220, -- sort_order
v_reporting_menu, -- parent_menu_id
null -- p_visible_tcl
);
return 0;
end;' language 'plpgsql';
-- Execute and then drop the function
select inline_0 ();
drop function inline_0 ();
-- Create a report showing all projects into
-- which the %user_id% can log hours.
--
SELECT im_report_new (
'REST My Timesheet Projects', -- report_name
'rest_my_timesheet_projects', -- report_code
'intranet-rest', -- package_key
100, -- report_sort_order
(select menu_id from im_menus where label = 'reporting-rest'), -- parent_menu_id
'select child.*,
tree_level(child.tree_sortkey)-1 as level,
im_category_from_id(child.project_type_id) as project_type,
im_category_from_id(child.project_status_id) as project_status
from
im_projects parent,
im_projects child,
acs_rels r
where
parent.parent_id is null and
child.project_type_id not in (
select 81 UNION select child_id from im_category_hierarchy where parent_id = 81
) and
child.tree_sortkey between parent.tree_sortkey and tree_right(parent.tree_sortkey) and
r.object_id_one = parent.project_id and
r.object_id_two = %user_id%
order by
child.tree_sortkey
'
);
update im_reports
set report_description = '
Returns the list of all projects to which the current user
has the right to log hours. Currently, we are assuming the
"permissive" hour logging model, so this report shows all
parent projects where the user is a member, plus all of their
child projects.
'
where report_code = 'rest_my_timesheet_projects';
SELECT acs_permission__grant_permission(
(select menu_id from im_menus where label = 'rest_my_timesheet_projects'),
(select group_id from groups where group_name = 'Employees'),
'read'
);
-- Create a report showing all hours logged by
-- the current user today.
--
SELECT im_report_new (
'REST My Hours', -- report_name
'rest_my_hours', -- report_code
'intranet-rest', -- package_key
110, -- report_sort_order
(select menu_id from im_menus where label = 'reporting-rest'), -- parent_menu_id
'
select h.*
from im_hours h
where h.user_id = %user_id% and
h.day >= now()::date
'
);
update im_reports
set report_description = '
Returns all hours logged today by the current user.
'
where report_code = 'rest_my_hours';
SELECT acs_permission__grant_permission(
(select menu_id from im_menus where label = 'rest_my_hours'),
(select group_id from groups where group_name = 'Employees'),
'read'
);
-- Create a report showing a category as a hierarchy.
--
SELECT im_report_new (
'REST Category Type', -- report_name
'rest_category_type', -- report_code
'intranet-rest', -- package_key
120, -- report_sort_order
(select menu_id from im_menus where label = 'reporting-rest'), -- parent_menu_id
'
select im_category_path_to_category(category_id) as tree_sortkey,
c.*
from im_categories c
where (c.enabled_p is null OR c.enabled_p = ''t'') and
category_type = %category_type%
order by tree_sortkey
'
);
update im_reports
set report_description = '
Returns a category type ordered by tree_sortkey
'
where report_code = 'rest_category_type';
SELECT acs_permission__grant_permission(
(select menu_id from im_menus where label = 'rest_category_type'),
(select group_id from groups where group_name = 'Employees'),
'read'
);
----------------------------------------------------------------------
-- Permission "Report"
----------------------------------------------------------------------
-- The report shows all permission associated with a specific object.
-- The report expects an "object_id" parameter.
--
SELECT im_report_new (
'REST Object Permissions', -- report_name
'rest_object_permissions', -- report_code
'intranet-rest', -- package_key
110, -- report_sort_order
(select menu_id from im_menus where label = 'reporting-rest'), -- parent_menu_id
'
select grantee_id, privilege
from acs_permissions
where object_id = %object_id%
'
);
update im_reports
set report_description = '
Returns all permissions define for one object.
'
where report_code = 'rest_object_permissions';
SELECT acs_permission__grant_permission(
(select menu_id from im_menus where label = 'rest_object_permissions'),
(select group_id from groups where group_name = 'Employees'),
'read'
);
----------------------------------------------------------------------
-- Group Membership Report
----------------------------------------------------------------------
-- Show all groups to which a specific user belongs.
-- By default shows the groups for the current user.
-- Expects a "user_id" parameter.
--
SELECT im_report_new (
'REST Group Memberships', -- report_name
'rest_group_membership', -- report_code
'intranet-rest', -- package_key
120, -- report_sort_order
(select menu_id from im_menus where label = 'reporting-rest'), -- parent_menu_id
'
select group_id
from group_distinct_member_map
where member_id = %object_id%
'
);
update im_reports
set report_description = 'Returns all groups to which a user belongs.'
where report_code = 'rest_group_membership';
SELECT acs_permission__grant_permission(
(select menu_id from im_menus where label = 'rest_group_membership'),
(select group_id from groups where group_name = 'Employees'),
'read'
);
SELECT im_report_new (
'REST My Timesheet Projects and Hours', -- report_name
'rest_my_timesheet_projects_hours', -- report_code
'intranet-rest', -- package_key
110, -- report_sort_order
(select menu_id from im_menus where label = 'reporting-rest'), -- parent_menu_id
'select child.project_id,
child.parent_id,
tree_level(child.tree_sortkey)-1 as level,
child.project_name,
child.project_nr,
child.company_id,
acs_object__name(child.company_id) as company_name,
child.project_type_id,
child.project_status_id,
im_category_from_id(child.project_type_id) as project_type,
im_category_from_id(child.project_status_id) as project_status,
h.hours,
h.note,
h.material_id,
acs_object__name(h.material_id) as material_name
from
im_projects parent,
im_projects child
LEFT OUTER JOIN (
select *
from im_hours h
where h.user_id = %user_id% and
h.day::date = ''%date%''::date
) h ON (child.project_id = h.project_id),
acs_rels r
where
parent.parent_id is null and
parent.project_status_id in (select * from im_sub_categories(76) union select * from im_sub_categories(71)) and
child.project_status_id not in (select * from im_sub_categories(81)) and
child.tree_sortkey between parent.tree_sortkey and tree_right(parent.tree_sortkey) and
r.object_id_one = parent.project_id and
r.object_id_two = %user_id%
order by
child.tree_sortkey
'
);
update im_reports
set report_description = '
Returns the list of all projects to which the current user
has the right to log hours, together with the list of hours
logged as of the specified %date% URL parameter.'
where report_code = 'rest_my_timesheet_projects_hours';
SELECT acs_permission__grant_permission(
(select menu_id from im_menus where label = 'rest_my_timesheet_projects_hours'),
(select group_id from groups where group_name = 'Employees'),
'read'
);
intranet-rest-v5-0-2-4-1/sql/postgresql/intranet-rest-drop.sql 0000775 0000000 0000000 00000002334 13175625757 0024313 0 ustar 00root root 0000000 0000000 -- /package/intranet-forum/sql/intranet-notes-drop.sql
--
-- Copyright (c) 2003-2006 ]project-open[
--
-- All rights reserved. Please check
-- http://www.project-open.com/license/ for details.
--
-- @author frank.bergmann@project-open.com
-- Drop plugins and menus for the module
--
select im_component_plugin__del_module('intranet-notes');
select im_menu__del_module('intranet-notes');
-----------------------------------------------------------
-- Drop main structures info
-- Drop functions
drop function im_note__name(integer);
drop function im_note__new (
integer, varchar, timestamptz,
integer, varchar, integer,
varchar, integer, integer, integer
);
drop function im_note__delete(integer);
-- Drop the main table
drop table im_notes;
-- Delete entries from acs_objects
delete from acs_objects where object_type = 'im_note';
-- Completely delete the object type from the
-- object system
SELECT acs_object_type__drop_type ('im_note', 't');
-----------------------------------------------------------
-- Drop Categories
--
drop view im_note_status;
drop view im_note_type;
delete from im_categories where category_type = 'Intranet Notes Status';
delete from im_categories where category_type = 'Intranet Notes Type';
intranet-rest-v5-0-2-4-1/tcl/ 0000775 0000000 0000000 00000000000 13175625757 0015604 5 ustar 00root root 0000000 0000000 intranet-rest-v5-0-2-4-1/tcl/intranet-rest-authentication-procs.tcl 0000664 0000000 0000000 00000016467 13175625757 0025266 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-procs.tcl
#
# Copyright (C) 2009 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Component Library - Authentication
@author frank.bergmann@project-open.com
}
ad_proc -private im_rest_cookie_auth_user_id {
{-debug 1}
} {
Determine the user_id even if ns_conn doesn't work
in a HTTP PUT call
} {
# Get the user_id from the ad_user_login cookie
set header_vars [ns_conn headers]
set cookie_string [ns_set get $header_vars Cookie]
set cookie_list [split $cookie_string ";"]
array set cookie_hash {}
foreach l $cookie_list {
if {[regexp {([^ =]+)\=(.+)} $l match key value]} {
set key [ns_urldecode [string trim $key]]
set value [ns_urldecode [string trim $value]]
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: key=$key, value=$value" }
set cookie_hash($key) $value
}
}
set rest_user_id ""
if {[info exists cookie_hash(ad_session_id)]} {
set ad_session_id $cookie_hash(ad_session_id)
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: ad_session_id=$ad_session_id" }
set rest_user_id ""
catch { set rest_user_id [ad_conn user_id] }
if {"" ne $rest_user_id && 0 != $rest_user_id} {
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: found authenthicated rest_user_id=$rest_user_id from ad_session_id cookie: storing into cache" }
ns_cache set im_rest $ad_session_id $rest_user_id
return $rest_user_id
}
if {[ns_cache get im_rest $ad_session_id value]} {
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: Didn't find authenticated rest_user_id: returning cached value" }
return $value
}
}
if {[info exists cookie_hash(ad_user_login)]} {
set ad_user_login $cookie_hash(ad_user_login)
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: ad_user_login=$ad_user_login" }
set rest_user_id ""
catch { set rest_user_id [ad_conn user_id] }
if {"" ne $rest_user_id && 0 != $rest_user_id} {
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: found authenticated rest_user_id=$rest_user_id from ad_user_login cookie: storing into cache" }
ns_cache set im_rest $ad_user_login $rest_user_id
return $rest_user_id
}
if {[ns_cache get im_rest $ad_user_login value]} {
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: Didn't find authenticated rest_user_id: returning cached value" }
return $value
}
}
if {$debug} { ns_log Notice "im_rest_cookie_auth_user_id: Didn't find any information, returning {}" }
return ""
}
ad_proc -private im_rest_authenticate {
{-debug 1}
{-format "json" }
-query_hash_pairs:required
} {
Determine the authenticated user
} {
if {$debug} { ns_log Notice "im_rest_authenticate: Starting: query_hash_pairs=$query_hash_pairs" }
array set query_hash $query_hash_pairs
set header_vars [ns_conn headers]
# --------------------------------------------------------
# Check for token authentication
set token_user_id ""
set token_token ""
if {[info exists query_hash(user_id)]} { set token_user_id $query_hash(user_id)}
if {[info exists query_hash(auth_token)]} { set token_token $query_hash(auth_token)}
if {[info exists query_hash(auto_login)]} { set token_token $query_hash(auto_login)}
# Check if the token fits the user
if {"" ne $token_user_id && "" ne $token_token} {
if {$debug} { ns_log Notice "im_rest_authenticate: Found auth_token=$token_token with user_id=$token_user_id" }
set valid_p [im_valid_auto_login_p -user_id $token_user_id -auto_login $token_token -check_user_requires_manual_login_p 0]
if {$debug} { ns_log Notice "im_rest_authenticate: valid_p=$valid_p" }
if {$valid_p} {
if {$debug} { ns_log Notice "im_rest_authenticate: auth_token was valid, user_id=$token_user_id" }
return [list "user_id" $token_user_id "method" "token"]
} else {
if {$debug} { ns_log Notice "im_rest_authenticate: auth_token was invalid, ignoring" }
set token_user_id ""
}
}
if {$debug} { ns_log Notice "im_rest_authenticate: Did not find valid auth_token" }
# --------------------------------------------------------
# Check for HTTP "basic" authorization
# Example: Authorization=Basic cHJvam9wOi5mcmFiZXI=
set basic_auth [ns_set get $header_vars "Authorization"]
set basic_auth_userpass ""
set basic_auth_username ""
set basic_auth_password ""
if {[regexp {^([a-zA-Z_]+)\ (.*)$} $basic_auth match method userpass_base64]} {
set basic_auth_userpass [base64::decode $userpass_base64]
regexp {^([^\:]+)\:(.*)$} $basic_auth_userpass match basic_auth_username basic_auth_password
if {$debug} { ns_log Notice "im_rest_authenticate: basic_auth: basic_auth_username=$basic_auth_username, basic_auth_password=$basic_auth_password" }
} else {
if {$debug} { ns_log Notice "im_rest_authenticate: basic_auth: basic_auth=$basic_auth does not match with regexp" }
}
set basic_auth_user_id [db_string userid "select user_id from users where lower(username) = lower(:basic_auth_username)" -default ""]
if {"" == $basic_auth_user_id} {
set basic_auth_user_id [db_string userid "select party_id from parties where lower(email) = lower(:basic_auth_username)" -default ""]
}
set basic_auth_password_ok_p undefined
if {"" != $basic_auth_user_id} {
set basic_auth_password_ok_p [ad_check_password $basic_auth_user_id $basic_auth_password]
if {!$basic_auth_password_ok_p} { set basic_auth_user_id "" }
}
if {$debug} { ns_log Notice "im_rest_authenticate: format=$format, basic_auth=$basic_auth, basic_auth_username=$basic_auth_username, basic_auth_password=$basic_auth_password, basic_auth_user_id=$basic_auth_user_id, basic_auth_password_ok_p=$basic_auth_password_ok_p" }
# --------------------------------------------------------
# Determine the user_id from cookie.
# Work around missing ns_conn user_id values in PUT and DELETE calls
set cookie_auth_user_id [im_rest_cookie_auth_user_id]
if {$debug} { ns_log Notice "im_rest_authenticate: cookie_auth_user_id=$cookie_auth_user_id" }
# Determine authentication method used
set auth_method ""
if {"" != $cookie_auth_user_id && 0 != $cookie_auth_user_id } { set auth_method "cookie" }
if {"" != $token_token} { set auth_method "token" }
if {"" != $basic_auth_user_id} { set auth_method "basic" }
# --------------------------------------------------------
# Check if one of the methods was successful...
switch $auth_method {
cookie { set auth_user_id $cookie_auth_user_id }
token { set auth_user_id $token_user_id }
basic { set auth_user_id $basic_auth_user_id }
default {
return [im_rest_error -format $format -http_status 401 -message "No authentication found ('$auth_method')."]
}
}
# internal debugging: Try to track down issue #42853
if {[im_table_exists crm_online_interactions]} {
set user_system_id [im_opt_val system_id]
if {"" ne $user_system_id} {
crm_basic_interaction -interaction_type_id 3235 -system_id $user_system_id -message [im_url_with_query]
}
}
if {$debug} { ns_log Notice "im_rest_authenticate: format=$format, auth_method=$auth_method, auth_user_id=$auth_user_id" }
return [list user_id $auth_user_id method $auth_method]
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-create-procs.tcl 0000664 0000000 0000000 00000235030 13175625757 0023477 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-create-procs.tcl
#
# Copyright (C) 2009-2010 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Component Library
@author frank.bergmann@project-open.com
This file contains object creation scripts for a number
of object types.
}
# -------------------------------------------------------
# Index
#
# Project
# Ticket
# Gantt Task
# Translation Task
# Company
# User Absence
# User
# Invoice
# Invoice Item (fake object)
# Hour (fake object, create + update)
# -------------------------------------------------------
# -------------------------------------------------------
# Project
# -------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_project {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_project" }
{ -rest_otype_pretty "Project" }
} {
Create a new object and return the object_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_projects_p [im_permission $rest_user_id "add_projects"]
if {!$add_projects_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create projects"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
# Check that all required variables are there
set required_vars {project_name project_nr}
foreach var $required_vars {
if {![info exists hash_array($var)]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Default values for not required vars
if {![info exists hash_array(project_path)]} { set hash_array(project_path) $hash_array(project_nr) }
if {![info exists hash_array(company_id)]} { set hash_array(company_id) [im_company_internal] }
if {![info exists hash_array(parent_id)]} { set hash_array(parent_id) "" }
if {![info exists hash_array(project_status_id)]} { set hash_array(project_status_id) [im_project_status_open] }
if {![info exists hash_array(project_type_id)]} { set hash_array(project_type_id) [im_project_type_gantt] }
if {![info exists hash_array(start_date)]} { set hash_array(start_date) [util_memoize [list db_string y "select to_char(now(), 'YYYY-01-01')"]] }
if {![info exists hash_array(end_date)]} { set hash_array(end_date) [util_memoize [list db_string y "select to_char(now(), 'YYYY-12-31')"]] }
set project_name $hash_array(project_name)
set project_nr $hash_array(project_nr)
set project_path $hash_array(project_path)
set parent_id $hash_array(parent_id)
# Check for duplicate
set parent_sql "parent_id = :parent_id"
if {"" == $parent_id} { set parent_sql "parent_id is NULL" }
set dup_sql "
select count(*)
from im_projects
where $parent_sql and
( upper(trim(project_name)) = upper(trim(:project_name)) OR
upper(trim(project_nr)) = upper(trim(:project_nr)) OR
upper(trim(project_path)) = upper(trim(:project_path))
)
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your project_name, project_nr or project_path already exists for the specified parent_id."]
}
if {[catch {
set rest_oid [im_project::new \
-creation_user $rest_user_id \
-context_id "" \
-project_name $hash_array(project_name) \
-project_nr $hash_array(project_nr) \
-project_path $hash_array(project_path) \
-company_id $hash_array(company_id) \
-parent_id $hash_array(parent_id) \
-project_type_id $hash_array(project_type_id) \
-project_status_id $hash_array(project_status_id) \
]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
# Write Audit Trail
im_audit -object_id $rest_oid -action after_create
# Add the creating user as a member, so that he's got the right to modify the project if he is not a privileged user
im_biz_object_add_role $rest_user_id $rest_oid [im_biz_object_role_project_manager]
set hash_array(rest_oid) $rest_oid
return [array get hash_array]
}
# -------------------------------------------------------
# Ticket
# -------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_ticket {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_ticket" }
{ -rest_otype_pretty "Ticket" }
} {
Create a new object and return its object_id
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_tickets_p [im_permission $rest_user_id "add_tickets"]
if {!$add_tickets_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create tickets"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Create optional variables if they haven't been specified in the request
if {![info exists project_nr]} {
set project_nr [db_nextval "im_ticket_seq"]
set hash_array(project_nr) $project_nr
}
if {![info exists ticket_customer_contact_id]} {
set ticket_customer_contact_id ""
set hash_array(ticket_customer_contact_id) $ticket_customer_contact_id
}
if {![info exists ticket_start_date]} {
set ticket_start_date ""
set hash_array(ticket_start_date) $ticket_start_date
}
if {![info exists ticket_end_date]} {
set ticket_end_date ""
set hash_array(ticket_end_date) $ticket_end_date
}
if {![info exists ticket_note]} {
set ticket_note ""
set hash_array(ticket_note) $ticket_note
}
if {![info exists ticket_status_id]} {
set ticket_status_id 30000
set hash_array(ticket_status_id) $ticket_status_id
}
if {![info exists ticket_type_id]} {
set ticket_type_id 30110
set hash_array(ticket_type_id) $ticket_type_id
}
# Check that all required variables are there
set required_vars {project_name parent_id}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicates
set parent_sql "parent_id = :parent_id"
if {"" == $parent_id} { set parent_sql "parent_id is NULL" }
set dup_sql "
select count(*)
from im_tickets t,
im_projects p
where t.ticket_id = p.project_id and
$parent_sql and
(upper(trim(p.project_name)) = upper(trim(:project_name)) OR
upper(trim(p.project_nr)) = upper(trim(:project_nr)))
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your ticket_name or project_nr already exists."]
}
# Check for valid parent_id
set company_id [db_string ticket_company "select company_id from im_projects where project_id = :parent_id" -default ""]
if {"" == $company_id} {
return [im_rest_error -format $format -http_status 406 -message "Invalid $rest_otype_pretty field 'parent_id': parent_id should represent an 'open' project of type 'Ticket Container'. This ticket container will become the container for the ticket."]
}
if {[catch {
db_transaction {
set rest_oid [im_ticket::new \
-ticket_sla_id $parent_id \
-ticket_name $project_name \
-ticket_nr $project_nr \
-ticket_customer_contact_id $ticket_customer_contact_id \
-ticket_type_id $ticket_type_id \
-ticket_status_id $ticket_status_id \
-ticket_start_date $ticket_start_date \
-ticket_end_date $ticket_end_date \
-ticket_note $ticket_note \
]
}
} err_msg]} {
ns_log Notice "im_rest_post_object_type_im_ticket: Error creating $rest_otype_pretty: '$err_msg'"
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
ns_log Notice "im_rest_post_object_type_im_ticket: Error creating $rest_otype_pretty during update: '$err_msg'"
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
# Write Audit Trail
im_audit -object_id $rest_oid -action after_create
ns_log Notice "im_rest_post_object_type_im_ticket: Successfully created object with object_id=$rest_oid"
set hash_array(rest_oid) $rest_oid
set hash_array(ticket_id) $rest_oid
return [array get hash_array]
}
# -------------------------------------------------------
# Gantt Task
# -------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_timesheet_task {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -hash_array_list ""}
{ -rest_oid "" }
{ -rest_otype "im_timesheet_task" }
{ -rest_otype_pretty "Gantt Task" }
} {
Create a new object and return its object_id
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_timesheet_tasks"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create projects"]
}
# Store the values into local variables
set project_nr ""
set project_status_id ""
set project_type_id ""
set planned_units ""
set billable_units ""
set percent_completed 0
set cost_center_id ""
set material_id ""
set invoice_id ""
set priority ""
set sort_order ""
set gantt_project_id ""
set note ""
# Extract a key-value list of variables from JSON POST request
if {"" != $hash_array_list} {
array set hash_array $hash_array_list
} else {
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
}
if {"" == $project_status_id} {
set project_status_id [im_project_status_open]
set hash_array(project_status_id) $project_status_id
}
if {"" == $project_type_id} {
set project_type_id [im_project_type_task]
set hash_array(project_type_id) $project_type_id
}
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Create default values if not yet set
if {"" == $material_id} {
set material_id [im_material_default_material_id]
set hash_array(material_id) $material_id
}
if {"" == $uom_id} {
set uom_id 320
set hash_array(uom_id) $uom_id
}
if {"" == $project_nr} {
set nr_prefix "task_"
set nr_digits 4
set project_nr [db_string oid "select nextval('t_acs_object_id_seq') + 1"]
while {[string length $project_nr] < $nr_digits} { set project_nr "0$project_nr" }
set project_nr "$nr_prefix$project_nr"
set hash_array(project_nr) $project_nr
}
# Check that all required variables are there
set required_vars {project_name project_nr parent_id project_status_id project_type_id uom_id material_id}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# More checks
if {"" == $parent_id} {
return [im_rest_error -format $format -http_status 406 -message "Variable 'parent_id' is not a valid project_id."]
}
# Check if the user has write permissions on the parent_id project
im_project_permissions $rest_user_id $parent_id view_p read_p write_p admin_p
if {!$write_p} {
return [im_rest_error -format $format -http_status 406 -message "User #$rest_user_id does not have write permissions on parent project #$parent_id."]
}
# Check for duplicates
set dup_sql "
select count(*)
from im_timesheet_tasks t,
im_projects p
where t.task_id = p.project_id and
p.parent_id = :parent_id and
(upper(trim(p.project_name)) = upper(trim(:project_name)) OR
upper(trim(p.project_nr)) = upper(trim(:project_nr)))
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your project_name='$project_name' or project_nr='$project_nr' already exists below parent_id=$parent_id."]
}
if {[catch {
db_transaction {
set rest_oid [db_string new_task "
SELECT im_timesheet_task__new (
:rest_oid, -- p_task_id
'im_timesheet_task', -- object_type
now(), -- creation_date
:rest_user_id, -- creation_user
'[ad_conn peeraddr]', -- creation_ip
null, -- context_id
:project_nr,
:project_name,
:parent_id,
:material_id,
:cost_center_id,
:uom_id,
:project_type_id,
:project_status_id,
:note
)
"]
}
} err_msg]} {
ns_log Notice "im_rest_post_object_type_$rest_otype: Error creating $rest_otype_pretty: '$err_msg'"
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(task_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Translation Task
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_trans_task {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_trans_task" }
{ -rest_otype_pretty "Translation Task" }
} {
Create a new object and return the object_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions:
# No specific permission required to create translation tasks.
# Just write permissions on the project
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {task_name project_id task_type_id task_status_id source_language_id target_language_id task_uom_id}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check if the user has write permissions on the parent_id project
im_project_permissions $rest_user_id $project_id view_p read_p write_p admin_p
if {!$write_p} {
return [im_rest_error -format $format -http_status 406 -message "User #$rest_user_id does not have write permissions on parent project #$project_id."]
}
# Check for duplicate
set dup_sql "
select count(*)
from im_trans_tasks
where project_id = :project_id and
task_name = :task_name and
target_language_id = :target_language_id
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your task_name and target_language_id already exists for the specified parent_id."]
}
if {[catch {
set rest_oid [db_string new_trans_task "
select im_trans_task__new (
null, -- task_id
'im_trans_task', -- object_type
now(), -- creation_date
:rest_user_id, -- creation_user
'[ns_conn peeraddr]', -- creation_ip
null, -- context_id
:project_id, -- project_id
:task_type_id, -- task_type_id
:task_status_id, -- task_status_id
:source_language_id, -- source_language_id
:target_language_id, -- target_language_id
:task_uom_id -- task_uom_id
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(task_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Company
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_company {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_company" }
{ -rest_otype_pretty "Company" }
} {
Create a new Company and return the company_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_companies"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create companies"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# --------------------------------------------
# Check that all required variables are there
set required_vars {company_name}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# --------------------------------------------
# Make sure the variable "company_path" exists.
if {![info exists company_path] || "" == $company_path} {
# Take company_name, make it lower and replace any strange chars with "_"
set company_path [string tolower $company_name]
regsub -all {[^a-z0-9]} $company_path "_" company_path
set hash_array(company_path) $company_path
}
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# --------------------------------------------
# Check for duplicate
set dup_sql "
select count(*)
from im_companies
where (lower(company_path) = lower(:company_path) OR
lower(company_name) = lower(:company_name))
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your company_name or company_path already exists."]
}
# Special case: The direction of a company is stored in it's "Office".
# So let's create a new office if the variable "main_office_id" isn't
# defined.
ns_log Notice "im_rest_post_object_type_$rest_otype: Before new main_office_id for company"
if {![info exists main_office_id] || "" == $main_office_id || 0 == $main_office_id} {
ns_log Notice "im_rest_post_object_type_$rest_otype: Create new main_office_id for company"
# Make sure all important fields are somehow defined
if {![info exists office_name] || "" == $office_name} { set office_name "[im_opt_val company_name] Main Office" }
if {![info exists office_path] || "" == $office_path} {
# Take company_name, make it lower and replace any strange chars with "_"
set office_path [string tolower [im_opt_val company_name]]
regsub -all {[^a-z0-9]} $office_path "_" office_path
}
if {![info exists office_status_id] || "" == $office_status_id} { set office_status_id [im_office_status_active] }
if {![info exists office_type_id] || "" == $office_type_id} { set office_type_id [im_office_type_main] }
set main_office_id [db_string office_exists "select office_id from im_offices where office_name = :office_name" -default ""]
if {"" == $main_office_id} {
set main_office_id [im_office::new \
-office_name $office_name \
-office_path $office_path \
-office_type_id $office_type_id \
-office_status_id $office_status_id
]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype "im_office" \
-rest_oid $main_office_id \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating im_office: '$err_msg'."]
}
set hash_array(main_office_id) $main_office_id
}
# Create some default parameters in order to reduce the number of parameters necessary
if {![info exists company_status_id] || "" == $company_status_id} {
# By default make the company "active"
set company_status_id [im_company_status_active]
set hash_array(company_status_id) $company_status_id
}
if {![info exists company_type_id] || "" == $company_type_id} {
# By default create a "customer" (should be more frequent then "provider"...)
set company_type_id [im_company_type_customer]
set hash_array(company_type_id) $company_type_id
}
if {[catch {
set rest_oid [db_string new_company "
select im_company__new (
null, -- task_id
'im_company', -- object_type
now(), -- creation_date
:rest_user_id, -- creation_user
'[ns_conn peeraddr]', -- creation_ip
null, -- context_id
:company_name,
:company_path,
:main_office_id,
:company_type_id,
:company_status_id
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(company_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Absence
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_user_absence {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_user_absence" }
{ -rest_otype_pretty "User Absence" }
} {
Create a new User Absence and return the company_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_absences"]
set add_all_p [im_permission $rest_user_id "add_absences_all"]
set add_direct_reports_p [im_permission $rest_user_id "add_absences_direct_reports"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create absences"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
set contact_info ""
set group_id ""
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars { absence_name owner_id duration_days absence_type_id absence_status_id start_date end_date description }
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Advanced permissions are necessary to log absences for others
if {$rest_user_id != $owner_id} {
if {!$add_all_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create absences for users other than himself"]
}
# ToDo: Deal with privilesges add_absences_direct_reports and add_absences_all
}
# Check for duplicate
set dup_sql "
select count(*)
from im_user_absences
where owner_id = :owner_id and
absence_type_id = :absence_type_id and
start_date = :start_date
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your combination of owner_id=$owner_id, start_date=$start_date and absence_type_id=$absence_type_id already exists."]
}
if {[catch {
set start_date_sql [template::util::date get_property sql_timestamp $start_date]
set end_date_sql [template::util::date get_property sql_timestamp $end_date]
set rest_oid [db_string new_absence "
SELECT im_user_absence__new(
null,
'im_user_absence',
now(),
:rest_user_id,
'[ns_conn peeraddr]',
null,
:absence_name,
:owner_id,
$start_date_sql,
$end_date_sql,
:absence_status_id,
:absence_type_id,
:description,
:contact_info
)
"]
db_dml update_absence "
update im_user_absences set
duration_days = :duration_days,
group_id = :group_id
where absence_id = :rest_oid
"
db_dml update_object "
update acs_objects set
last_modified = now()
where object_id = :rest_oid
"
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(absence_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# User
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_user {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "user" }
{ -rest_otype_pretty "User" }
} {
Create a new User object return the user_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: Started"
# Permissions
set add_p [im_permission $rest_user_id "add_users"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create users"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {first_names last_name}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Fake the following required variables
if {![info exists username] || "" == $username} {
set username "$first_names $last_name"
set hash_array(username) $username
ns_log Notice "im_rest_post_object_type_$rest_otype: Set username=$username"
}
if {![info exists screen_name] || "" == $screen_name} {
set screen_name $username
set hash_array(screen_name) $screen_name
ns_log Notice "im_rest_post_object_type_$rest_otype: Set screen_name=$screen_name"
}
if {![info exists email] || "" == $email} {
set email "${first_names}.${last_name}@nowhere.com"
set email [string tolower $email]
regsub -all {[^a-zA-Z0-9_\-@]} $email "." email
set hash_array(email) $email
ns_log Notice "im_rest_post_object_type_$rest_otype: Set email=$email"
}
if {![info exists password] || "" == $password} {
set password [ad_generate_random_string]
set hash_array(password) $password
ns_log Notice "im_rest_post_object_type_$rest_otype: Set password=$password"
}
if {![info exists url] || "" == $url} {
set url ""
set hash_array(url) $url
ns_log Notice "im_rest_post_object_type_$rest_otype: Set url=$url"
}
# Check for duplicate
set dup_sql "
select count(*)
from users u,
persons pe,
parties pa
where u.user_id = pe.person_id and
u.user_id = pa.party_id and
( lower(u.username) = lower(:username) OR
lower(pa.email) = lower(:email)
)
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your username or email already exist."]
}
if {[catch {
ns_log Notice "im_rest_post_object_type_user: before auth::create_user -username $username -email $email -first_names $first_names -last_name $last_name -screen_name $screen_name -password $password -url $url"
array set creation_info [auth::create_user \
-username $username \
-email $email \
-first_names $first_names \
-last_name $last_name \
-screen_name $screen_name \
-password $password \
-url $url \
]
ns_log Notice "im_rest_post_object_type_user: after auth::create_user"
if { "ok" != $creation_info(creation_status) || "ok" != $creation_info(account_status)} {
ns_log Notice "im_rest_post_object_type_user: User creation unsuccessfull: [array get creation_status]"
return [im_rest_error -format $format -http_status 406 -message "User creation unsuccessfull: [array get creation_status]"]
}
set new_user_id $creation_info(user_id)
# Update creation user to allow the creator to admin the user
db_dml update_creation_user_id "
update acs_objects
set creation_user = :rest_user_id
where object_id = :new_user_id
"
ns_log Notice "im_rest_post_object_type_user: person::update -person_id=$new_user_id -first_names=$first_names -last_name=$last_name"
person::update \
-person_id $new_user_id \
-first_names $first_names \
-last_name $last_name
ns_log Notice "im_rest_post_object_type_user: party::update -party_id=$new_user_id -url=$url -email=$email"
party::update \
-party_id $new_user_id \
-url $url \
-email $email
ns_log Notice "im_rest_post_object_type_user: acs_user::update -rest_user_id=$new_user_id -screen_name=$screen_name"
acs_user::update \
-rest_user_id $new_user_id \
-screen_name $screen_name \
-username $username
# Add the user to the "Registered Users" group, because
# (s)he would get strange problems otherwise
# Use a non-cached version here to avoid issues!
set registered_users [im_registered_users_group_id]
set reg_users_rel_exists_p [db_string member_of_reg_users "
select count(*)
from group_member_map m, membership_rels mr
where m.member_id = :new_user_id
and m.group_id = :registered_users
and m.rel_id = mr.rel_id
and m.container_id = m.group_id
and m.rel_type::text = 'membership_rel'::text
"]
if {!$reg_users_rel_exists_p} {
relation_add -member_state "approved" "membership_rel" $registered_users $new_user_id
}
# Add a im_employees record to the user since the 3.0 PostgreSQL
# port, because we have dropped the outer join with it...
if {[im_table_exists im_employees]} {
# Simply add the record to all users, even it they are not employees...
set im_employees_exist [db_string im_employees_exist "select count(*) from im_employees where employee_id = :new_user_id"]
if {!$im_employees_exist} {
db_dml add_im_employees "insert into im_employees (employee_id) values (:new_user_id)"
}
}
# Add a im_freelancers record to the user since the 3.0 PostgreSQL
# port, because we have dropped the outer join with it...
if {[im_table_exists im_freelancers]} {
# Simply add the record to all users, even it they are not freelancers...
set im_freelancers_exist [db_string im_freelancers_exist "select count(*) from im_freelancers where user_id = :new_user_id"]
if {!$im_freelancers_exist} {
db_dml add_im_freelancers "insert into im_freelancers (user_id) values (:new_user_id)"
}
}
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $new_user_id \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $new_user_id -action after_create
set rest_oid $new_user_id
set hash_array(rest_oid) $rest_oid
set hash_array(user_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Invoices
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_invoice {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_invoice" }
{ -rest_otype_pretty "Financial Document" }
} {
Create a new Financial Document and return the task_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_invoices"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create invoices"]
}
# Store the key-value pairs into local variables
set note ""
set amount 0
set currency "EUR"
set vat ""
set tax ""
set payment_days 0
set payment_method_id ""
set template_id ""
set company_contact_id ""
set effective_date [db_string effdate "select now()::date"]
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars { invoice_nr customer_id provider_id cost_status_id cost_type_id}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from im_invoices
where invoice_nr = :invoice_nr
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your specified invoice_nr='$invoice_nr' already exists."]
}
if {[catch {
set rest_oid [db_string new_invoice "
select im_invoice__new (
NULL, -- invoice_id
'im_invoice', -- object_type
now(), -- creation_date
:rest_user_id, -- creation_user
'[ad_conn peeraddr]', -- creation_ip
null, -- context_id
:invoice_nr, -- invoice_nr
:customer_id, -- customer_id
:provider_id, -- provider_id
:company_contact_id, -- company_contact_id
:effective_date, -- effective_date
:currency, -- currency
:template_id, -- template_id
:cost_status_id, -- cost_status_id
:cost_type_id, -- cost_type_id
:payment_method_id, -- payment_method_id
:payment_days, -- payment_days
:amount, -- amount
:vat, -- vat
:tax, -- tax
:note -- note
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(invoice_id) $rest_oid
return [array get hash_array]
}
ad_proc -private im_rest_post_object_type_im_trans_invoice {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_trans_invoice" }
{ -rest_otype_pretty "Translation Financial Document" }
} {
Create a new object and return the object_id
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_invoices"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create translation invoices"]
}
set rest_oid [ \
im_rest_post_object_type_im_trans_invoice \
-format $format \
-rest_user_id $rest_user_id \
-content $content \
-rest_otype $rest_otype \
-rest_otype_pretty $rest_otype_pretty \
]
db_dml insert_trans_invoice "
insert into im_trans_invoices (invoice_id) values (:rest_oid)
"
db_dml update_trans_invoice "
update acs_objects
set object_type = 'im_trans_invoice'
where object_id = :rest_oid
"
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(invoice_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Invoice Items - It's not really an object type,
# so we have to fake it here.
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_invoice_item {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_invoice_item" }
{ -rest_otype_pretty "Financial Document Item" }
} {
Create a new Financial Document line and return the item_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_invoices"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create invoice items"]
}
# store the key-value pairs into a hash array
set description ""
set item_material_id ""
set item_type_id ""
set item_status_id ""
set invoice_id ""
set project_id ""
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars { item_name invoice_id sort_order item_uom_id item_units price_per_unit currency }
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from im_invoice_items
where item_name = :item_name and
invoice_id = :invoice_id and
sort_order = :sort_order
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your item already exists with the specified invoice_name, invoice_id and sort_order."]
}
if {[catch {
set rest_oid [db_string item_id "select nextval('im_invoice_items_seq')"]
db_dml new_invoice_item "
insert into im_invoice_items (
item_id,
item_name,
invoice_id,
item_uom_id,
sort_order
) values (
:rest_oid,
:item_name,
:invoice_id,
:item_uom_id,
:sort_order
)
"
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
# re-calculate the amount of the invoice
im_invoice_update_rounded_amount -invoice_id $invoice_id
# No audit here, invoice_item is not a real object
# im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(item_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# im_hour
# Not an object type really, so we have to fake it here.
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_hour {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_hour" }
{ -rest_otype_pretty "Timesheet Hour" }
} {
Create a new Timesheet Hour line and return the item_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_hours"]
set add_all_p [im_permission $rest_user_id "add_hours_all"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create hours"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars { user_id project_id day hours note }
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Hour permissions
if {$user_id != $rest_user_id} {
if {!$add_all_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create hours for others than himself"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from im_hours
where user_id = :user_id and
project_id = :project_id and
day = :day
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your item already exists with the specified user, project and day."]
}
if {[catch {
set rest_oid [db_string item_id "select nextval('im_hours_seq')"]
db_dml new_im_hour "
insert into im_hours (
hour_id,
user_id,
project_id,
day,
hours,
note
) values (
:rest_oid,
:user_id,
:project_id,
:day,
:hours,
:note
)
"
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
# Not a real object, so no audit!
# im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(hour_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# im_hour_interval
# Not an object type really, so we have to fake it here.
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_hour_interval {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_hour_interval" }
{ -rest_otype_pretty "Timesheet Interval" }
} {
Create a new Timesheet Hour line and return the item_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_hours"]
set add_all_p [im_permission $rest_user_id "add_hours_all"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to add hours"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars { user_id project_id interval_start interval_end note }
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
# Fix timestamp format between JavaScript and PostgreSQL 8.4/9.x
# Wed Jul 23 2014 19:23:26 GMT+0200 (Romance Daylight Time)
switch $var {
interval_start - interval_end {
set val [im_rest_normalize_timestamp [im_opt_val $var]]
set $var $val
set hash_array($var) $val
}
}
}
# Permission Check: Only log hours for yourself
if {$user_id != $rest_user_id} {
return [im_rest_error -format $format -http_status 403 -message "You can log hours only for yourself."]
}
# Check for duplicate
set dup_sql "
select count(*)
from im_hour_intervals
where user_id = :user_id and
project_id = :project_id and
interval_start = :interval_start
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your item already exists with the specified user, project and interval_start."]
}
# Create the new object
if {[catch {
set rest_oid [db_string item_id "select nextval('im_hour_intervals_seq')"]
db_dml new_im_hour_interval "
insert into im_hour_intervals (
interval_id,
user_id,
project_id,
interval_start,
interval_end,
note
) values (
:rest_oid,
:user_id,
:project_id,
:interval_start,
:interval_end,
:note
)
"
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
# Not a real object, so no audit!
# im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(interval_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Task Dependencies - It's not really an object type,
# so we have to fake it here.
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_timesheet_task_dependency {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_timesheet_task_dependency" }
{ -rest_otype_pretty "Gantt Task Dependency" }
} {
Create a new task dependency and return the id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_timesheet_tasks"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create timesheet task dependencies"]
}
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# Set default variables
if {![info exists hash_array(dependency_status_id)] || "" == $hash_array(dependency_status_id) } { set hash_array(dependency_status_id) 9740 }
if {![info exists hash_array(dependency_type_id)] || "" == $hash_array(dependency_type_id) } { set hash_array(dependency_type_id) 9650 }
if {![info exists hash_array(difference)] || "" == $hash_array(difference) } { set hash_array(difference) 0 }
if {![info exists hash_array(hardness_type_id)]} { set hash_array(hardness_type_id) "" }
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {task_id_one task_id_two dependency_type_id}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select dependency_id
from im_timesheet_task_dependencies
where task_id_one = :task_id_one and
task_id_two = :task_id_two
"
set rest_oid [db_string duplicate $dup_sql -default ""]
if {"" != $rest_oid} {
ns_log Warning "im_rest_post_object_type_$rest_otype: duplicate dependency: task_id_one=$task_id_one, task_id_two=$task_id_two"
set hash_array(rest_oid) $rest_oid
set hash_array(dependency_id) $rest_oid
return [array get hash_array]
# return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your objectalready exists with the specified task_id_one and task_id_two."]
}
if {[catch {
set rest_oid [db_string item_id "select nextval('im_timesheet_task_dependency_seq')"]
db_dml new_timesheet_task_dependency "
insert into im_timesheet_task_dependencies (
dependency_id,
task_id_one,
task_id_two,
dependency_type_id,
dependency_status_id,
difference,
hardness_type_id
) values (
:rest_oid,
:task_id_one,
:task_id_two,
:dependency_type_id,
:dependency_status_id,
:difference,
:hardness_type_id
)
"
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
set hash_array(rest_oid) $rest_oid
set hash_array(dependency_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# im_note
#
ad_proc -private im_rest_post_object_type_im_note {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_otype_pretty "Note" }
{ -rest_oid "" }
{ -content "" }
{ -debug 0 }
} {
Handler for POST calls on particular im_note objects.
im_note is not a real object type and performs a "delete"
operation specifying hours=0 or hours="".
} {
ns_log Notice "im_rest_post_object_im_note: rest_oid=$rest_oid"
# Permissions
set add_p [im_permission $rest_user_id "add_projects"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create projects"]
}
set creation_user $rest_user_id
set creation_ip [ad_conn peeraddr]
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {note note_status_id note_type_id object_id}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from im_notes
where note = :note and
object_id = :object_id
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: The note already exists for the specified object."]
}
if {[catch {
set rest_oid [db_string new_im_note "
select im_note__new (
null, -- note_id
:rest_otype, -- object_type
now(), -- creation_date
:creation_user,
:creation_ip,
null, -- context_id
:note,
:object_id,
:note_type_id,
:note_status_id
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -status_id $note_status_id -type_id $note_type_id -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(rel_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Membership Relationshiop
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_membership_rel {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "membership_rel" }
{ -rest_otype_pretty "Membership Relationship" }
} {
Create a new object and return the object_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_projects"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create projects"]
}
# Store values into local variables
set rel_type "membership_rel"
set member_state "appoved"
set creation_user $rest_user_id
set creation_ip [ad_conn peeraddr]
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {object_id_one object_id_two}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from acs_rels
where rel_type = :rest_otype and
object_id_one = :object_id_one and
object_id_two = :object_id_two
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your company_name or company_path already exists."]
}
if {[catch {
set rest_oid [db_string new_membership_rel "
select membership_rel__new (
null, -- task_id
:rest_otype, -- object_type
:object_id_one,
:object_id_two,
:member_state,
:rest_user_id, -- creation_user
'[ns_conn peeraddr]'
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(rel_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Business Object Membership
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_biz_object_member {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_biz_object_member" }
{ -rest_otype_pretty "Biz Object Relationship" }
} {
Create a new object and return the object_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Store values into local variables
set rel_type $rest_otype
set creation_ip [ad_conn peeraddr]
set sort_order ""
# Extract a key-value list of variables from JSON POST request
ns_log Notice "im_rest_post_object_type_$rest_otype: Now parsing json content ..."
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {object_id_one object_id_two}
foreach var $required_vars {
if {![info exists $var]} {
ns_log Notice "im_rest_post_object_type_$rest_otype: Variable '$var' not specified. The following variables are required: $required_vars"
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
ns_log Notice "im_rest_post_object_type_$rest_otype: Found all necessary var's"
if {![info exists percentage]} { set percentage "" }
if {![info exists object_role_id]} { set object_role_id [im_biz_object_role_full_member] }
# Permissions
set breach_p [im_security_alert_check_integer -location "im_rest_post_object_type_im_biz_object_member" -value $object_id_one]
if {$breach_p} { return }
set object_type [util_memoize [list db_string object_type "select object_type from acs_objects where object_id = $object_id_one" -default ""]]
if {"" == $object_type} {
return [im_rest_error -format $format -http_status 403 -message "Could not find business object_id=$object_id_one."]
}
set perm_cmd "${object_type}_permissions \$rest_user_id \$object_id_one view_p read_p write_p admin_p"
eval $perm_cmd
if {!$write_p} {
return [im_rest_error -format $format -http_status 403 -message "You don not have write permissions on object_id=$object_id_one"]
}
set rest_oid [im_biz_object_add_role -current_user_id $rest_user_id -percentage $percentage $object_id_two $object_id_one $object_role_id]
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(rel_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Ticket-Ticket Relationshiop
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_ticket_ticket_rel {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_ticket_ticket_rel" }
{ -rest_otype_pretty "Ticket-Ticket Relationship" }
} {
Create a new object and return the object_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_projects"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create projects"]
}
# Store values into local variables
set rel_type $rest_otype
set creation_ip [ad_conn peeraddr]
set sort_order ""
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {object_id_one object_id_two}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from acs_rels
where rel_type = :rest_otype and
object_id_one = :object_id_one and
object_id_two = :object_id_two
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your company_name or company_path already exists."]
}
if {[catch {
set rest_oid [db_string new_im_ticket_ticket_rel "
select im_ticket_ticket_rel__new (
null, -- task_id
:rest_otype, -- object_type
:object_id_one,
:object_id_two,
null, -- context_id
:rest_user_id,
'[ns_conn peeraddr]'
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(rel_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Key-Account Relationship
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_key_account_rel {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_key_account_rel" }
{ -rest_otype_pretty "Key Account Relationship" }
} {
Create a new object and return the object_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_projects"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create projects"]
}
# Store values into local variables
set rel_type $rest_otype
set creation_ip [ad_conn peeraddr]
set sort_order ""
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {object_id_one object_id_two}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from acs_rels
where rel_type = :rest_otype and
object_id_one = :object_id_one and
object_id_two = :object_id_two
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your company_name or company_path already exists."]
}
if {[catch {
set rest_oid [db_string new_im_key_account_rel "
select im_key_account_rel__new (
null, -- task_id
:rest_otype, -- object_type
:object_id_one,
:object_id_two,
null, -- context_id
:rest_user_id,
'[ns_conn peeraddr]'
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(rel_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# Company-Employee Relationship
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type_im_company_employee_rel {
{ -format "json" }
{ -rest_user_id 0 }
{ -content "" }
{ -rest_otype "im_company_employee_rel" }
{ -rest_otype_pretty "Company Employee Relationship" }
} {
Create a new object and return the object_id.
} {
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_user_id=$rest_user_id"
# Permissions
set add_p [im_permission $rest_user_id "add_projects"]
if {!$add_p} {
return [im_rest_error -format $format -http_status 403 -message "User #$rest_user_id does not have the right to create projects"]
}
# Store values into local variables
set rel_type $rest_otype
set creation_ip [ad_conn peeraddr]
set sort_order ""
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
ns_log Notice "im_rest_post_object_type_$rest_otype: key=$key, value=$value"
set $key $value
}
# Check that all required variables are there
set required_vars {object_id_one object_id_two}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select count(*)
from acs_rels
where rel_type = :rest_otype and
object_id_one = :object_id_one and
object_id_two = :object_id_two
"
if {[db_string duplicates $dup_sql]} {
return [im_rest_error -format $format -http_status 406 -message "Duplicate $rest_otype_pretty: Your company_name or company_path already exists."]
}
if {[catch {
set rest_oid [db_string new_im_company_employee_rel "
select im_company_employee_rel__new (
null, -- task_id
:rest_otype, -- object_type
:object_id_one,
:object_id_two,
null, -- context_id
:rest_user_id,
'[ns_conn peeraddr]'
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_create
set hash_array(rest_oid) $rest_oid
set hash_array(rel_id) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# im_sencha_preference
#
ad_proc -private im_rest_post_object_type_im_sencha_preference {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_otype_pretty "Sencha Preference" }
{ -rest_oid "" }
{ -content "" }
{ -debug 0 }
} {
Handler for POST calls on particular im_sencha_preference objects.
} {
ns_log Notice "im_rest_post_object_im_sencha_preference: rest_oid=$rest_oid"
set creation_user $rest_user_id
set creation_ip [ad_conn peeraddr]
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# Default values for not required vars
if {![info exists hash_array(preference_status_id)] || "" == $hash_array(preference_status_id)} { set hash_array(preference_status_id) [im_sencha_preference_status_active] }
if {![info exists hash_array(preference_type_id)] || "" == $hash_array(preference_type_id)} { set hash_array(preference_type_id) [im_sencha_preference_type_default] }
if {![info exists hash_array(preference_object_id)] || "" == $hash_array(preference_object_id)} { set hash_array(preference_object_id) $rest_user_id }
# Permissions
# No permissions are necessary if the user changes preferences for preference_object_id = current_user_id
set preference_object_id $hash_array(preference_object_id)
if {$rest_user_id != $preference_object_id} {
set object_type [util_memoize [list db_string object_type "select object_type from acs_objects where object_id = $preference_object_id" -default ""]]
if {"" == $object_type} {
return [im_rest_error -format $format -http_status 403 -message "Could not find preference_object_id=$preference_object_id."]
}
set perm_cmd "${object_type}_permissions \$user_id \$object_id view_p read_p write_p admin_p"
eval $perm_cmd
if {!$write_p} {
return [im_rest_error -format $format -http_status 403 -message "You don not have write permissions on object_id=$preference_object_id"]
}
}
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
set $key $value
}
# Check that all required variables are there
set required_vars {preference_url preference_key preference_value}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select preference_id
from im_sencha_preferences
where preference_object_id = :preference_object_id and
preference_url = :preference_url and
preference_key = :preference_key
"
ns_log Notice "im_rest_post_object_type_$rest_otype: before executing dup_sql: preference_object_id=$preference_object_id, preference_url=$preference_url, preference_key=$preference_key, dup_sql=$dup_sql"
set rest_oid [db_string duplicates $dup_sql -default 0]
ns_log Notice "im_rest_post_object_type_$rest_otype: rest_oid='$rest_oid'"
if {$rest_oid} {
# Exception: Just update the preference.
db_dml update_preference "
update im_sencha_preferences set
preference_value = :preference_value
where preference_id = :rest_oid
"
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -status_id $preference_status_id -type_id $preference_type_id -action after_update
} else {
# Create a new preference
if {[catch {
set rest_oid [db_string new_im_sencha_preference "
select im_sencha_preference__new (
null, :rest_otype, now(), :creation_user, :creation_ip, null, -- object params
:preference_type_id,
:preference_status_id,
:preference_object_id,
:preference_url,
:preference_key,
:preference_value
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -status_id $preference_status_id -type_id $preference_type_id -action after_create
}
set hash_array(rest_oid) $rest_oid
return [array get hash_array]
}
# --------------------------------------------------------
# im_sencha_column_config
#
ad_proc -private im_rest_post_object_type_im_sencha_column_config {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_otype_pretty "Sencha Column Config" }
{ -rest_oid "" }
{ -content "" }
{ -debug 0 }
} {
Handler for POST calls on particular im_sencha_column_config objects.
} {
ns_log Notice "im_rest_post_object_im_sencha_column_config: rest_oid=$rest_oid"
set creation_user $rest_user_id
set creation_ip [ad_conn peeraddr]
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_type_$rest_otype: hash_array=[array get hash_array]"
# Default values for not required vars
if {![info exists hash_array(column_config_status_id)] || "" == $hash_array(column_config_status_id)} { set hash_array(column_config_status_id) [im_sencha_column_config_status_active] }
if {![info exists hash_array(column_config_type_id)] || "" == $hash_array(column_config_type_id)} { set hash_array(column_config_type_id) [im_sencha_column_config_type_default] }
if {![info exists hash_array(column_config_object_id)] || "" == $hash_array(column_config_object_id)} { set hash_array(column_config_object_id) $rest_user_id }
# Permissions
# No permissions are necessary if the user changes column_configs for column_config_object_id = current_user_id
set column_config_object_id $hash_array(column_config_object_id)
if {$rest_user_id != $column_config_object_id} {
set object_type [util_memoize [list db_string object_type "select object_type from acs_objects where object_id = $column_config_object_id" -default ""]]
if {"" == $object_type} {
return [im_rest_error -format $format -http_status 403 -message "Could not find column_config_object_id=$column_config_object_id."]
}
set perm_cmd "${object_type}_permissions \$user_id \$object_id view_p read_p write_p admin_p"
eval $perm_cmd
if {!$write_p} {
return [im_rest_error -format $format -http_status 403 -message "You don not have write permissions on object_id=$column_config_object_id"]
}
}
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
set $key $value
}
# Check that all required variables are there
set required_vars {column_config_url column_config_name}
foreach var $required_vars {
if {![info exists $var]} {
return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
}
}
# Check for duplicate
set dup_sql "
select column_config_id
from im_sencha_column_configs
where column_config_object_id = :column_config_object_id and
column_config_url = :column_config_url and
column_config_name = :column_config_name
"
set rest_oid [db_string duplicates $dup_sql -default 0]
if {0 == $rest_oid} {
# Create a new column_config
if {[catch {
set rest_oid [db_string new_im_sencha_column_config "
select im_sencha_column_config__new (
null, -- column_config_id
:rest_otype, -- object_type
now(), -- creation_date
:creation_user,
:creation_ip,
null, -- context_id
:column_config_type_id,
:column_config_status_id,
:column_config_object_id,
:column_config_url,
:column_config_name
)
"]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error creating $rest_otype_pretty: '$err_msg'."]
}
}
if {[catch {
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
} err_msg]} {
return [im_rest_error -format $format -http_status 406 -message "Error updating $rest_otype_pretty: '$err_msg'."]
}
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -status_id $column_config_status_id -type_id $column_config_type_id -action after_create
set hash_array(rest_oid) $rest_oid
return [array get hash_array]
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-data-source-procs.tcl 0000664 0000000 0000000 00000032575 13175625757 0024454 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-procs.tcl
#
# Copyright (C) 2009 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Component Library
@author frank.bergmann@project-open.com
}
# ---------------------------------------------------------------
# Task-Tree: Create and update tasks based on Procedure to update a task
# ---------------------------------------------------------------
ad_proc im_rest_project_task_tree_action {
{ -pass 0}
{ -action "" }
-var_hash_list:required
} {
Create, Update or Delete a task coming from TreeStore
@param pass: 0:all actions, 1: create/update only, 2: dependencies only
@return 0 if everything OK, 1 if we need to repeat
} {
ns_log Notice "im_rest_project_task_tree_action: pass=$pass, var_hash_list=$var_hash_list"
set current_user_id [ad_conn user_id]
array set var_hash $var_hash_list
# Handle issues with "true" or "false" in milestone_p breaking the DB char(1) data-type
if {[info exists var_hash(milestone_p)]} { set var_hash(milestone_p) [string range $var_hash(milestone_p) 0 0] }
# Ignore the root of the tree that might be send by the Sencha side
set id ""
if {[info exists var_hash(id)]} { set id $var_hash(id) }
if {"root" == $id} { return; }
# Check the project_id/task_id
set project_id ""
if {[info exists var_hash(project_id)] && "" != $var_hash(project_id)} { set project_id $var_hash(project_id) }
if {[info exists var_hash(task_id)] && "" != $var_hash(task_id)} { set project_id $var_hash(task_id) }
if {[info exists var_hash(id)] && "" != $var_hash(id)} { set project_id $var_hash(id) }
# Check if parent_id exists. All tasks should have a parent_id. Otherwise it's the main project.
set parent_id ""
if {[info exists var_hash(parent_id)]} { set parent_id $var_hash(parent_id) }
set parent_id_exists_p [db_string parent_exists "select count(*) from im_projects where project_id = :parent_id"]
ns_log Notice "im_rest_project_task_tree_action: parent_id=$parent_id, exists=$parent_id_exists_p, pass=$pass, var_hash_list=$var_hash_list"
if {"" ne $parent_id && !$parent_id_exists_p} {
ns_log Notice "im_rest_project_task_tree_action: parent_id=$parent_id does not yet exist in the DB, looping:\npass=$pass, var_hash_list=$var_hash_list"
return 1
}
switch $action {
update { im_rest_project_task_tree_update -pass $pass -project_id $project_id -var_hash_list [array get var_hash] }
create { im_rest_project_task_tree_create -pass $pass -project_id $project_id -var_hash_list [array get var_hash] }
delete { im_rest_project_task_tree_delete -pass $pass -project_id $project_id -var_hash_list [array get var_hash] }
default {
doc_return 200 "text/plain" "{success:false, message: 'tree_action: found invalid action=[im_quotejson $action]'}"
return
}
}
# The calling procedure will return a suitable JSON success message
}
ad_proc im_rest_project_task_tree_update {
{-pass 0}
-project_id:required
-var_hash_list:required
} {
Update a task coming from TreeStore
@param pass: 0:all actions, 1: create/update only, 2: dependencies only
} {
ns_log Notice "im_rest_project_task_tree_update: pass=$pass, project_id=$project_id, var_hash_list=$var_hash_list"
set current_user_id [ad_conn user_id]
array set var_hash $var_hash_list
if {"" == $project_id} {
doc_return 200 "text/plain" "{success:false, message: 'Did not find project_id in JSON data: [im_quotejson $var_hash_list]'}"
return
}
# project_id exists - update the existing task
set object_type [db_string otype "select object_type from acs_objects where object_id = $project_id" -default ""]
if {"" == $object_type} {
# task doesn't exist yet - so this is a "create" instead of an "update" action
ns_log Notice "im_rest_project_task_tree_update: pass=$pass, project_id=$project_id: Didn't find project - redirecting to 'create' action"
set result [im_rest_project_task_tree_create -pass $pass -project_id $project_id -var_hash_list $var_hash_list]
return $result
}
${object_type}_permissions $current_user_id $project_id view read write admin
if {!$write} {
doc_return 200 "text/plain" "{success:false, message: 'User #$current_user_id ([im_name_from_user_id $current_user_id]) has not enough permissions
to modify task or project #$project_id ([acs_object_name $project_id])'}"
return
}
# Update the main project fields via a generic REST routine
if {0 eq $pass || 1 eq $pass} {
im_rest_object_type_update_sql \
-format "json" \
-rest_otype "im_timesheet_task" \
-rest_oid $project_id \
-hash_array $var_hash_list
}
# Update assignees
im_rest_project_task_tree_assignees -project_id $project_id -var_hash_list $var_hash_list
# Update predecessors
if {0 eq $pass || 2 eq $pass} {
if {[info exists var_hash(predecessors)]} {
im_rest_project_task_tree_predecessors -project_id $project_id -var_hash_list $var_hash_list
}
}
}
ad_proc im_rest_project_task_tree_delete {
{-pass 0}
-project_id:required
-var_hash_list:required
} {
Delete a task coming from TreeStore
} {
ns_log Notice "im_rest_project_task_tree_delete: pass=$pass, project_id=$project_id, var_hash_list=$var_hash_list"
set current_user_id [ad_conn user_id]
array set var_hash $var_hash_list
if {"" == $project_id} {
doc_return 200 "text/plain" "{success:false, message: \"Delete failed because we did not find project_id in JSON data: [im_quotejson $var_hash_list]\"}"
return
}
# project_id exists - update the existing task
set object_type [util_memoize [list db_string otype "select object_type from acs_objects where object_id = $project_id" -default ""]]
if {"" eq $object_type} { return }; # Delete object before it really was created. Kind of OK...
${object_type}_permissions $current_user_id $project_id view read write admin
if {!$admin} {
doc_return 200 "text/plain" "{success:false, message: \"No permissions to admin project_id=$project_id for user=$current_user_id\"}"
return
}
if {2 eq $pass} {
set parent_id [db_string task_parent_id "select parent_id from im_projects where project_id = :project_id" -default ""]
# Found the main project. We don't want to delete this project.
if {"" == $parent_id} { continue }
# Nuke including timesheet costs logged, task dependencies etc
ns_log Notice "im_rest_project_task_tree_delete: before 'im_project_nuke $project_id'"
set err_msg [im_project_nuke $project_id]
if {"" ne $err_msg} {
doc_return 200 "text/plain" "{success:false, message: \"[im_quotejson $err_msg]\"}"
return
}
}
}
ad_proc im_rest_project_task_tree_create {
{-pass 0}
-project_id:required
-var_hash_list:required
} {
Create a new task coming from TreeStore
@param pass: 0:all actions, 1: create/update only, 2: dependencies only
} {
ns_log Notice "im_rest_project_task_tree_create: pass=$pass, project_id=$project_id, var_hash_list=$var_hash_list"
set current_user_id [ad_conn user_id]
array set var_hash $var_hash_list
# No project_id!
if {"" != $project_id && [db_string exists_p "select count(*) from im_projects where project_id=:project_id"]} {
doc_return 200 "text/plain" "{success:false, message: 'Create failed, project_id=$project_id already exists. JSON data: [im_quotejson $var_hash_list]'}"
return
}
set parent_id ""
if {[info exists var_hash(parent_id)]} { set parent_id $var_hash(parent_id) }
if {"" == $parent_id} {
doc_return 200 "text/plain" "{success:false, message: 'Create failed, no parent_id specified for new task in post data: [im_quotejson $var_hash_list]'}"
return
}
set parent_object_type [util_memoize [list db_string otype "select object_type from acs_objects where object_id = $parent_id"]]
${parent_object_type}_permissions $current_user_id $parent_id view read write admin
if {!$write} {
doc_return 200 "text/plain" "{success:false, message: 'No permissions to write to parent_id=$parent_id for user=$current_user_id'}"
return
}
# ToDo: What does this call return, do we need to check the result?
if {0 eq $pass || 1 eq $pass} {
im_rest_post_object_type_im_timesheet_task \
-format "json" \
-rest_user_id $current_user_id \
-rest_oid $project_id \
-rest_otype "im_timesheet_task" \
-rest_otype_pretty "Gantt Task" \
-hash_array_list $var_hash_list
}
# Update assignees
if {[info exists var_hash(assignees)]} {
im_rest_project_task_tree_assignees -project_id $project_id -var_hash_list $var_hash_list
}
# Update predecessors on passes 0 or 2
if {0 eq $pass || 2 eq $pass} {
if {[info exists var_hash(predecessors)]} {
im_rest_project_task_tree_predecessors -project_id $project_id -var_hash_list $var_hash_list
}
}
}
# -------------------------------------------------------
# Update/Store assignees and predecessors
# -------------------------------------------------------
ad_proc im_rest_project_task_tree_assignees {
-project_id:required
-var_hash_list:required
} {
Update the resource assignees to the task
} {
ns_log Notice "im_rest_project_task_tree_assignees: project_id=$project_id, var_hash_list=$var_hash_list"
array set var_hash $var_hash_list
# Update task assignees
set assignees $var_hash(assignees)
ns_log Notice "im_rest_project_task_tree_assignees: assignees=$assignees"
set assignee_list [lindex $assignees 1]
set assignee_user_ids [list]
foreach assignee_object $assignee_list {
set object_hash_list [lindex $assignee_object 1]
ns_log Notice "im_rest_project_task_tree_assignees: object_hash=$object_hash_list"
array unset object_hash
array set object_hash $object_hash_list
set user_id $object_hash(user_id)
set percent $object_hash(percent)
lappend assignee_user_ids $user_id
# Add the dude to the project and update percentage
set rel_id [im_biz_object_add_role $user_id $project_id [im_biz_object_role_full_member]]
db_dml update_assignation "update im_biz_object_members set percentage = :percent where rel_id = :rel_id"
ns_log Notice "im_rest_project_task_tree_assignees: rel_id=$rel_id"
}
# Delete assignees that are not in the list anymore
set db_assigned_user_ids [db_list db_assig "select object_id_two from acs_rels where rel_type = 'im_biz_object_member' and object_id_one = :project_id"]
ns_log Notice "im_rest_project_task_tree_assignees: db_assigned_user_ids=$db_assigned_user_ids"
foreach db_uid $db_assigned_user_ids {
if {[lsearch $assignee_user_ids $db_uid] < 0} {
# The db_uid is still available in the DB, but not in the new data: delete it!
ns_log Notice "im_rest_project_task_tree_assignees: found user_id=$db_uid assigned in the DB, but not in the new data - deleting"
db_string del_rel "select im_biz_object_member__delete(:project_id, :db_uid) from dual"
}
}
}
# ToDo: Delete dependencies!?!
ad_proc im_rest_project_task_tree_predecessors {
-project_id:required
-var_hash_list:required
} {
Update the resource predecessors to the task
} {
ns_log Notice "im_rest_project_task_tree_predecessors: project_id=$project_id, var_hash_list=$var_hash_list"
array set var_hash $var_hash_list
# Update task predecessors
set pred_list [list 0]
set predecessors $var_hash(predecessors)
ns_log Notice "im_rest_project_task_tree_predecessors: predecessors=$predecessors"
set predecessor_list [lindex $predecessors 1]
foreach predecessor_object $predecessor_list {
set object_hash_list [lindex $predecessor_object 1]
ns_log Notice "im_rest_project_task_tree_predecessors: object_hash=$object_hash_list"
array unset object_hash
array set object_hash $object_hash_list
set pred_id $object_hash(pred_id)
set succ_id $object_hash(succ_id)
set type_id $object_hash(type_id)
set diff $object_hash(diff)
# Create a list of all predecessor tasks
lappend pred_list $pred_id
# Check if the dependency already exists
set dependency_id [db_string dep_id "
select dependency_id
from im_timesheet_task_dependencies
where task_id_two = :pred_id and
task_id_one = :succ_id
" -default ""]
if {"" eq $dependency_id} {
ns_log Notice "im_rest_project_task_tree_predecessors: dependency_id does not exist - create new dependency"
# Add the dude
set insert_sql "
insert into im_timesheet_task_dependencies (
task_id_two, task_id_one, dependency_type_id, difference
) values (
:pred_id, :succ_id, :type_id, :diff
)
"
db_dml dep_insert $insert_sql
} else {
ns_log Notice "im_rest_project_task_tree_predecessors: dependency_id=$dependency_id already exists - updating"
# Update the dude
set update_sql "
update im_timesheet_task_dependencies set
difference = :diff,
dependency_type_id = :type_id
where task_id_two = :pred_id and
task_id_one = :succ_id
"
db_dml dep_update $update_sql
}
}
# Get the list of all predecessors in the DB that are not preds anymore
set preds_to_delete [db_list pred_list "
select dependency_id
from im_timesheet_task_dependencies ttd
where ttd.task_id_one = :project_id and
ttd.task_id_two not in ([join $pred_list ","])
"]
ns_log Notice "im_rest_project_task_tree_predecessors: the following preds need to be deleted: $preds_to_delete"
foreach pred_dep_id $preds_to_delete {
db_dml del_pred "delete from im_timesheet_task_dependencies where dependency_id = :pred_dep_id"
}
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-get-procs.tcl 0000664 0000000 0000000 00000125034 13175625757 0023015 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-get-procs.tcl
#
# Copyright (C) 2009 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Component Library
@author frank.bergmann@project-open.com
}
ad_proc -private im_rest_get_object_type {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for GET rest calls on a whole object type -
mapped to queries on the specified object type
} {
ns_log Notice "im_rest_get_object_type: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, rest_oid=$rest_oid, query_hash=$query_hash_pairs"
set org_format $format
set org_rest_oid $rest_oid
array set query_hash $query_hash_pairs
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = '$rest_otype'" -default 0]]
set rest_columns [im_rest_get_rest_columns $query_hash_pairs]
foreach col $rest_columns { set rest_columns_hash($col) 1 }
# Check if the deref_p parameter was set
array set query_hash $query_hash_pairs
set deref_p 0
if {[info exists query_hash(deref_p)]} { set deref_p $query_hash(deref_p) }
im_security_alert_check_integer -location "im_rest_get_object: deref_p" -value $deref_p
set base_url "[im_rest_system_url]/intranet-rest"
set chars_to_be_escaped_list [list \
"\"" "\\\"" \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t \
\x00 \\u0000 \x01 \\u0001 \x02 \\u0002 \x03 \\u0003 \
\x04 \\u0004 \x05 \\u0005 \x06 \\u0006 \x07 \\u0007 \
\x0b \\u000b \x0e \\u000e \x0f \\u000f \x10 \\u0010 \
\x11 \\u0011 \x12 \\u0012 \x13 \\u0013 \x14 \\u0014 \
\x15 \\u0015 \x16 \\u0016 \x17 \\u0017 \x18 \\u0018 \
\x19 \\u0019 \x1a \\u001a \x1b \\u001b \x1c \\u001c \
\x1d \\u001d \x1e \\u001e \x1f \\u001f \x7f \\u007f \
\x80 \\u0080 \x81 \\u0081 \x82 \\u0082 \x83 \\u0083 \
\x84 \\u0084 \x85 \\u0085 \x86 \\u0086 \x87 \\u0087 \
\x88 \\u0088 \x89 \\u0089 \x8a \\u008a \x8b \\u008b \
\x8c \\u008c \x8d \\u008d \x8e \\u008e \x8f \\u008f \
\x90 \\u0090 \x91 \\u0091 \x92 \\u0092 \x93 \\u0093 \
\x94 \\u0094 \x95 \\u0095 \x96 \\u0096 \x97 \\u0097 \
\x98 \\u0098 \x99 \\u0099 \x9a \\u009a \x9b \\u009b \
\x9c \\u009c \x9d \\u009d \x9e \\u009e \x9f \\u009f \
]
# -------------------------------------------------------
# Get some more information about the current object type
set otype_info [util_memoize [list db_list_of_lists rest_otype_info "select table_name, id_column from acs_object_types where object_type = '$rest_otype'"]]
set table_name [lindex $otype_info 0 0]
set id_column [lindex $otype_info 0 1]
if {"" == $table_name} {
im_rest_error -format $org_format -http_status 500 -message "Invalid DynField configuration: Object type '$rest_otype' doesn't have a table_name specified in table acs_object_types."
}
# Deal with ugly situation that usre_id is defined multiple times for object_type=user
if {"users" == $table_name} { set id_column "person_id" }
# -------------------------------------------------------
# Check for generic permissions to read all objects of this type
set rest_otype_read_all_p [im_object_permission -object_id $rest_otype_id -user_id $rest_user_id -privilege "read"]
# Deny completely access to the object type?
set rest_otype_read_none_p 0
if {!$rest_otype_read_all_p} {
# There are "view_..._all" permissions allowing a user to see all objects:
switch $rest_otype {
bt_bug { }
im_company { set rest_otype_read_all_p [im_permission $rest_user_id "view_companies_all"] }
im_cost { set rest_otype_read_all_p [im_permission $rest_user_id "view_finance"] }
im_conf_item { set rest_otype_read_all_p [im_permission $rest_user_id "view_conf_items_all"] }
im_invoices { set rest_otype_read_all_p [im_permission $rest_user_id "view_finance"] }
im_project { set rest_otype_read_all_p [im_permission $rest_user_id "view_projects_all"] }
im_user_absence { set rest_otype_read_all_p [im_permission $rest_user_id "view_absences_all"] }
im_office { set rest_otype_read_all_p [im_permission $rest_user_id "view_offices_all"] }
im_profile { set rest_otype_read_all_p 1 }
im_ticket { set rest_otype_read_all_p [im_permission $rest_user_id "view_tickets_all"] }
im_timesheet_task { set rest_otype_read_all_p [im_permission $rest_user_id "view_timesheet_tasks_all"] }
im_timesheet_invoices { set rest_otype_read_all_p [im_permission $rest_user_id "view_finance"] }
im_trans_invoices { set rest_otype_read_all_p [im_permission $rest_user_id "view_finance"] }
im_translation_task { }
user { }
default {
# No read permissions?
# Well, no object type except the ones above has a custom procedure,
# so we can deny access here:
set rest_otype_read_none_p 1
ns_log Notice "im_rest_get_object_type: Denying access to $rest_otype"
}
}
}
# -------------------------------------------------------
# Check if there is a where clause specified in the URL
# and validate the clause.
set where_clause ""
set where_clause_list [list]
set where_clause_unchecked_list [list]
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
if {"" != $where_clause} { lappend where_clause_list $where_clause }
ns_log Notice "im_rest_get_object_type: where_clause=$where_clause"
# -------------------------------------------------------
# Check if there are "valid_vars" specified in the HTTP header
# and add these vars to the SQL clause
set valid_vars [util_memoize [list im_rest_object_type_columns -deref_p $deref_p -rest_otype $rest_otype]]
foreach v $valid_vars {
if {[info exists query_hash($v)]} { lappend where_clause_list "$v=$query_hash($v)" }
}
# -------------------------------------------------------
# Check if there was a rest_oid provided as part of the URL
# for example /im_project/8799. In this case add the oid to
# the query.
# rest_oid was already security checked to be an integer.
if {"" != $rest_oid && 0 != $rest_oid} {
lappend where_clause_list "$id_column=$rest_oid"
}
# -------------------------------------------------------
# Transform the database table to deal with exceptions
#
switch $rest_otype {
user - person - party {
set table_name "(
select *
from users u, parties pa, persons pe
where u.user_id = pa.party_id and u.user_id = pe.person_id and
u.user_id in (
SELECT o.object_id
FROM acs_objects o,
group_member_map m,
membership_rels mr
WHERE m.member_id = o.object_id AND
m.group_id = acs__magic_object_id('registered_users'::character varying) AND
m.rel_id = mr.rel_id AND
m.container_id = m.group_id AND
m.rel_type::text = 'membership_rel'::text AND
mr.member_state = 'approved'
)
)"
}
file_storage_object {
# file storage object needs additional security
lappend where_clause_unchecked_list "'t' = acs_permission__permission_p(rest_oid, $rest_user_id, 'read')"
}
im_ticket {
# Testing per-ticket permissions
set read_sql [im_ticket_permission_read_sql -user_id $rest_user_id]
lappend where_clause_unchecked_list "rest_oid in ($read_sql)"
}
}
# Check that the where_clause elements are valid SQL statements
foreach where_clause $where_clause_list {
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $org_format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
}
# Build the complete where clause
set where_clause_list [concat $where_clause_list $where_clause_unchecked_list]
if {"" != $where_clause && [llength $where_clause_list] > 0} { append where_clause " and " }
append where_clause [join $where_clause_list " and\n\t\t"]
if {"" != $where_clause} { set where_clause "and $where_clause" }
# -------------------------------------------------------
# Select SQL: Pull out objects where the acs_objects.object_type
# is correct AND the object exists in the object type's primary table.
# This way we avoid "dangling objects" in acs_objects and sub-types.
set sql [im_rest_object_type_select_sql -deref_p $deref_p -rest_otype $rest_otype -no_where_clause_p 1]
append sql "
where o.object_type in ('[join [im_rest_object_type_subtypes -rest_otype $rest_otype] "','"]') and
o.object_id in (
select t.$id_column
from $table_name t
)\
"
# Add $where_clause to the outside of the SQL in order to
# avoid ambiguities of duplicate columns like "rel_id"
set sql "
select *
from ($sql
) t
where 1=1
$where_clause
"
# Append sorting "ORDER BY" clause to the sql.
append sql [im_rest_object_type_order_sql -query_hash_pairs $query_hash_pairs]
# Append pagination "LIMIT $limit OFFSET $start" to the sql.
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
# -------------------------------------------------------
# Loop through all objects of the specified type
set obj_ctr 0
set result ""
set user_id $rest_user_id
db_foreach objects $sql {
# Skip objects with empty object name
if {"" == $object_name} {
ns_log Error "im_rest_get_object_type: Skipping object #$object_id because object_name is empty."
continue
}
# -------------------------------------------------------
# Permissions
# Denied access?
if {$rest_otype_read_none_p} { continue }
# Check permissions
set read_p $rest_otype_read_all_p
if {!$read_p} {
# This is one of the "custom" object types - check the permission:
# This may be quite slow checking 100.000 objects one-by-one...
if {[catch {
ns_log Notice "im_rest_get_object_type: Checking for individual permissions: ${rest_otype}_permissions $rest_user_id $rest_oid"
eval "${rest_otype}_permissions $rest_user_id $rest_oid view_p read_p write_p admin_p"
# Write out error message only if the user has specified a single object to check. Otherwise just skip.
if {!$read_p && "" != $org_rest_oid} {
im_rest_error -format $org_format -http_status 403 -message "User #$rest_user_id does not have read access to object #$org_rest_oid"
return
}
} err_msg]} {
im_rest_error -format $org_format -http_status 500 -message "Internal error: $err_msg"
return
}
}
if {!$read_p} { continue }
switch $org_format {
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
# Skip the column unless it is explicitely mentioned in the rest_columns list
if {{} != $rest_columns} { if {![info exists rest_columns_hash($v)]} { continue } }
eval "set a $$v"
set a [string map $chars_to_be_escaped_list $a]
append dereferenced_result ", \"$v\": \"$a\""
}
append result "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[string map $chars_to_be_escaped_list $object_name]\"$dereferenced_result}"
}
html {
set url "$base_url/$rest_otype/$rest_oid"
append result "
[im_footer]
"
}
json {
set result "{\"success\": true,\n\"total\": $obj_ctr,\n\"message\": \"im_rest_get_object_type: Data loaded\",\n\"data\": \[\n$result\n\]\n}"
im_rest_doc_return 200 "application/json" $result
return
}
default {
ad_return_complaint 1 "im_rest_get_object_type: Invalid format5: '$org_format'"
return
}
}
}
ad_proc -private im_rest_get_im_invoice_items {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for GET rest calls on invoice items.
} {
ns_log Notice "im_rest_get_invoice_items: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, query_hash=$query_hash_pairs"
array set query_hash $query_hash_pairs
if {"" != $rest_oid} { set query_hash(item_id) $rest_oid }
set base_url "[im_rest_system_url]/intranet-rest"
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = 'im_invoice'" -default 0]]
set rest_otype_read_all_p [im_permission $rest_user_id "view_finance"]
# -------------------------------------------------------
# Check if there is a where clause specified in the URL and validate the clause.
set where_clause ""
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
# Determine the list of valid columns for the object type
set valid_vars {item_id item_name project_id invoice_id item_units item_uom_id price_per_unit currency sort_order item_type_id item_status_id description item_material_id}
# Check that the query is a valid SQL where clause
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
if {"" != $where_clause} { set where_clause "and $where_clause" }
# Select SQL: Pull out invoice_items.
set sql "
select ii.item_id as rest_oid,
ii.item_name as object_name,
ii.*
from im_invoice_items ii
where 1=1
$where_clause
"
# Append pagination "LIMIT $limit OFFSET $start" to the sql.
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
set result ""
set obj_ctr 0
db_foreach objects $sql {
# Check permissions
set read_p $rest_otype_read_all_p
if {!$read_p} { im_invoice_permissions $rest_user_id $invoice_id view_p read_p write_p admin_p }
if {!$read_p} { continue }
set url "$base_url/$rest_otype/$rest_oid"
switch $format {
html {
append result "
\n"
}
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
eval "set a $$v"
regsub -all {\n} $a {\n} a
regsub -all {\r} $a {} a
append dereferenced_result ", \"$v\": \"[im_quotejson $a]\""
}
append result "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[im_quotejson $object_name]\"$dereferenced_result}"
}
default {}
}
incr obj_ctr
}
switch $format {
html {
set page_title "object_type: $rest_otype"
im_rest_doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
object_id
Link
$result
[im_footer]
"
}
json {
set result "{\"success\": true,\n\"total\": $obj_ctr,\n\"message\": \"im_rest_get_im_invoice_items: Data loaded\",\n\"data\": \[\n$result\n\]\n}"
im_rest_doc_return 200 "application/json" $result
return
}
}
return
}
ad_proc -private im_rest_get_im_hours {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for GET rest calls on timesheet hours
} {
ns_log Notice "im_rest_get_im_hours: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, rest_oid=$rest_oid, query_hash=$query_hash_pairs"
array set query_hash $query_hash_pairs
if {"" != $rest_oid} { set query_hash(hour_id) $rest_oid }
set base_url "[im_rest_system_url]/intranet-rest"
# Permissions:
# A user can normally read only his own hours,
# unless he's got the view_hours_all privilege or explicitely
# the perms on the im_hour object type
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = 'im_hour'" -default 0]]
set rest_otype_read_all_p [im_object_permission -object_id $rest_otype_id -user_id $rest_user_id -privilege "read"]
if {[im_permission $rest_user_id "view_hours_all"]} { set rest_otype_read_all_p 1 }
set owner_perm_sql "and h.user_id = :rest_user_id"
if {$rest_otype_read_all_p} { set owner_perm_sql "" }
# -------------------------------------------------------
# Check if there is a where clause specified in the URL and validate the clause.
set where_clause ""
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
# Determine the list of valid columns for the object type
set valid_vars {hour_id user_id project_id day hours days note internal_note cost_id conf_object_id invoice_id material_id}
# -------------------------------------------------------
# Check if there are "valid_vars" specified in the HTTP header
# and add these vars to the SQL clause
set where_clause_list [list]
foreach v $valid_vars {
if {[info exists query_hash($v)]} { lappend where_clause_list "$v=$query_hash($v)" }
}
if {"" != $where_clause && [llength $where_clause_list] > 0} { append where_clause " and " }
append where_clause [join $where_clause_list " and "]
# Check that the query is a valid SQL where clause
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
if {"" != $where_clause} { set where_clause "and $where_clause" }
# Select SQL: Pull out hours.
set sql "
select h.hour_id as rest_oid,
'(' || im_name_from_user_id(user_id) || ', ' ||
im_project_name_from_id(h.project_id) ||
day::date || ', ' || ' - ' ||
h.hours || ')' as object_name,
h.*
from im_hours h
where 1=1
$owner_perm_sql
$where_clause
"
# Append pagination "LIMIT $limit OFFSET $start" to the sql.
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
set value ""
set result ""
set obj_ctr 0
db_foreach objects $sql {
# Check permissions
set read_p $rest_otype_read_all_p
if {!$read_p} { continue }
set url "$base_url/$rest_otype/$rest_oid"
switch $format {
html {
append result "
\n"
}
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
eval "set a $$v"
regsub -all {\n} $a {\n} a
regsub -all {\r} $a {} a
append dereferenced_result ", \"$v\": \"[im_quotejson $a]\""
}
append result "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[im_quotejson $object_name]\"$dereferenced_result}"
}
default {}
}
incr obj_ctr
}
switch $format {
html {
set page_title "object_type: $rest_otype"
im_rest_doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
object_id
Link
$result
[im_footer]
"
}
json {
set result "{\"success\": true,\n\"total\": $obj_ctr,\n\"message\": \"im_rest_get_im_hours: Data loaded\",\n\"data\": \[\n$result\n\]\n}"
im_rest_doc_return 200 "application/json" $result
return
}
}
return
}
ad_proc -private im_rest_get_im_hour_intervals {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for GET rest calls on timesheet hour intervals
} {
ns_log Notice "im_rest_get_im_hour_intervals: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, rest_oid=$rest_oid, query_hash=$query_hash_pairs"
array set query_hash $query_hash_pairs
if {"" != $rest_oid} { set query_hash(interval_id) $rest_oid }
set base_url "[im_rest_system_url]/intranet-rest"
# Permissions:
# A user can normally read only his own hours,
# unless he's got the view_hours_all privilege or explicitely
# the perms on the im_hour_interval object type
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = 'im_hour_interval'" -default 0]]
set rest_otype_read_all_p [im_object_permission -object_id $rest_otype_id -user_id $rest_user_id -privilege "read"]
if {[im_permission $rest_user_id "view_hours_all"]} { set rest_otype_read_all_p 1 }
set owner_perm_sql "and h.user_id = :rest_user_id"
if {$rest_otype_read_all_p} { set owner_perm_sql "" }
# -------------------------------------------------------
# Check if there is a where clause specified in the URL and validate the clause.
set where_clause ""
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
# Determine the list of valid columns for the object type
set valid_vars {interval_id user_id project_id interval_start interval_end note internal_note activity_id material_id}
# -------------------------------------------------------
# Check if there are "valid_vars" specified in the HTTP header
# and add these vars to the SQL clause
set where_clause_list [list]
foreach v $valid_vars {
if {[info exists query_hash($v)]} { lappend where_clause_list "$v=$query_hash($v)" }
}
if {"" != $where_clause && [llength $where_clause_list] > 0} { append where_clause " and " }
append where_clause [join $where_clause_list " and "]
# Check that the query is a valid SQL where clause
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
if {"" != $where_clause} { set where_clause "and $where_clause" }
# Select SQL: Pull out hours.
set sql "
select h.interval_id as rest_oid,
'(' || im_name_from_user_id(user_id) || ', ' ||
im_project_name_from_id(h.project_id) || ', ' ||
interval_start || ' - ' || interval_end || ')' as object_name,
h.*
from im_hour_intervals h
where 1=1
$owner_perm_sql
$where_clause
"
# Append pagination "LIMIT $limit OFFSET $start" to the sql.
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
set value ""
set result ""
set obj_ctr 0
db_foreach objects $sql {
# Check permissions
set read_p $rest_otype_read_all_p
if {!$read_p} { continue }
set url "$base_url/$rest_otype/$rest_oid"
switch $format {
html { append result "
\n" }
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
eval "set a $$v"
regsub -all {\n} $a {\n} a
regsub -all {\r} $a {} a
append dereferenced_result ", \"$v\": \"[im_quotejson $a]\""
}
append result "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[im_quotejson $object_name]\"$dereferenced_result}"
}
default {}
}
incr obj_ctr
}
switch $format {
html {
set page_title "object_type: $rest_otype"
im_rest_doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
object_id
Link
$result
[im_footer]
"
}
json {
set result "{\"success\": true,\n\"message\": \"im_rest_get_im_hour_intervals: Data loaded\",\n\"data\": \[\n$result\n\]\n}"
im_rest_doc_return 200 "application/json" $result
return
}
}
return
}
ad_proc -private im_rest_get_im_timesheet_task_dependencies {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for GET rest calls on task dependencies
} {
ns_log Notice "im_rest_get_timesheet_task_dependencies: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, query_hash=$query_hash_pairs"
array set query_hash $query_hash_pairs
if {"" != $rest_oid} { set query_hash(dependency_id) $rest_oid }
set base_url "[im_rest_system_url]/intranet-rest"
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = 'im_timesheet_task_dependency'" -default 0]]
# "harmless" data-type, we can allow reading for everybody
set rest_otype_read_all_p 1
# -------------------------------------------------------
# Check if there is a where clause specified in the URL and validate the clause.
set where_clause ""
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
# Determine the list of valid columns for the object type
set valid_vars {dependency_id dependency_status_id dependency_type_id task_id_one task_id_two difference hardness_type_id}
# -------------------------------------------------------
# Check if there are "valid_vars" specified in the HTTP header
# and add these vars to the SQL clause
set where_clause_list [list]
foreach v $valid_vars {
if {[info exists query_hash($v)]} { lappend where_clause_list "$v=$query_hash($v)" }
}
if {"" != $where_clause && [llength $where_clause_list] > 0} { append where_clause " and " }
append where_clause [join $where_clause_list " and "]
# Check that the query is a valid SQL where clause
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
if {"" != $where_clause} { set where_clause "and $where_clause" }
# Select SQL: Pull out timesheet_task_dependencies.
set sql "
select d.*,
d.dependency_id as rest_oid,
'Task Dependency ' || task_id_one || ' - ' || task_id_two as object_name
from im_timesheet_task_dependencies d
where 1=1
$where_clause
"
# Append pagination "LIMIT $limit OFFSET $start" to the sql.
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
set result ""
set obj_ctr 0
db_foreach objects $sql {
# Check permissions
set read_p $rest_otype_read_all_p
if {!$read_p} { continue }
set url "$base_url/$rest_otype/$rest_oid"
switch $format {
html {
append result "
\n"
}
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
eval "set a $$v"
regsub -all {\n} $a {\n} a
regsub -all {\r} $a {} a
append dereferenced_result ", \"$v\": \"[im_quotejson $a]\""
}
append result "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[im_quotejson $object_name]\"$dereferenced_result}"
}
default {}
}
incr obj_ctr
}
switch $format {
html {
set page_title "object_type: $rest_otype"
im_rest_doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
object_id
Link
$result
[im_footer]
"
}
json {
set result "{\"success\": true,\n\"total\": $obj_ctr,\n\"message\": \"im_rest_get_im_timesheet_task_dependencies: Data loaded\",\n\"data\": \[\n$result\n\]\n}"
im_rest_doc_return 200 "application/json" $result
return
}
}
return
}
ad_proc -private im_rest_get_im_categories {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for GET rest calls on invoice items.
} {
ns_log Notice "im_rest_get_im_categories: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, query_hash=$query_hash_pairs"
array set query_hash $query_hash_pairs
set base_url "[im_rest_system_url]/intranet-rest"
if {"" != $rest_oid} { set query_hash(category_id) $rest_oid }
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = 'im_category'" -default 0]]
set rest_otype_read_all_p [im_object_permission -object_id $rest_otype_id -user_id $rest_user_id -privilege "read"]
# Get locate for translation
set locale [lang::user::locale -user_id $rest_user_id]
# -------------------------------------------------------
# Valid variables to return for im_category
set valid_vars {category_id tree_sortkey category category_translated category_description category_type category_gif enabled_p parent_only_p aux_int1 aux_int2 aux_string1 aux_string2 sort_order}
# -------------------------------------------------------
# Check if there is a where clause specified in the URL and validate the clause.
set where_clause ""
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
# -------------------------------------------------------
# Check if there are "valid_vars" specified in the HTTP header
# and add these vars to the SQL clause
set where_clause_list [list]
foreach v $valid_vars {
if {[info exists query_hash($v)]} { lappend where_clause_list "$v=$query_hash($v)" }
}
if {"" != $where_clause && [llength $where_clause_list] > 0} { append where_clause " and " }
append where_clause [join $where_clause_list " and "]
# Check that the query is a valid SQL where clause
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
if {"" != $where_clause} { set where_clause "and $where_clause" }
# Select SQL: Pull out categories.
set sql "
select c.category_id as rest_oid,
c.category as object_name,
im_category_path_to_category(c.category_id) as tree_sortkey,
c.*
from im_categories c
where (c.enabled_p is null OR c.enabled_p = 't')
$where_clause
order by category_id
"
# Append pagination "LIMIT $limit OFFSET $start" to the sql.
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
set value ""
set result ""
set obj_ctr 0
db_foreach objects $sql {
set category_key "intranet-core.[lang::util::suggest_key $category]"
set category_translated [lang::message::lookup $locale $category_key $category]
# Calculate indent
set indent [expr {[string length tree_sortkey] - 8}]
# Check permissions
set read_p $rest_otype_read_all_p
if {!$read_p} { continue }
set url "$base_url/$rest_otype/$rest_oid"
switch $format {
html {
append result "
\n"
}
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
eval "set a $$v"
regsub -all {\n} $a {\n} a
regsub -all {\r} $a {} a
append dereferenced_result ", \"$v\": \"[im_quotejson $a]\""
}
append result "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[im_quotejson $object_name]\"$dereferenced_result}"
}
default {}
}
incr obj_ctr
}
switch $format {
html {
set page_title "object_type: $rest_otype"
im_rest_doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
object_id
Link
$result
[im_footer]
"
}
json {
set result "{\"success\": true,\n\"total\": $obj_ctr,\n\"message\": \"im_rest_get_im_categories: Data loaded\",\n\"data\": \[\n$result\n\]\n}"
im_rest_doc_return 200 "application/json" $result
return
}
}
return
}
ad_proc -private im_rest_get_im_dynfield_attributes {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for GET rest calls on dynfield attributes
} {
ns_log Notice "im_rest_get_im_dynfield_attributes: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, query_hash=$query_hash_pairs"
array set query_hash $query_hash_pairs
set base_url "[im_rest_system_url]/intranet-rest"
if {"" != $rest_oid} { set query_hash(attribute_id) $rest_oid }
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = 'im_dynfield_attribute'" -default 0]]
set rest_otype_read_all_p [im_object_permission -object_id $rest_otype_id -user_id $rest_user_id -privilege "read"]
set deref_p 0
if {[info exists query_hash(deref_p)]} { set deref_p $query_hash(deref_p) }
im_security_alert_check_integer -location "im_rest_get_im_dynfield_attributes: deref_p" -value $deref_p
# -------------------------------------------------------
# Check if there is a where clause specified in the URL and validate the clause.
set where_clause ""
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
# Determine the list of valid columns for the object type
set valid_vars [util_memoize [list im_rest_object_type_columns -deref_p $deref_p -rest_otype $rest_otype]]
set valid_vars [concat $valid_vars {object_type table_name attribute_name pretty_name pretty_plural datatype default_value min_n_values max_n_values storage static_p column_name}]
# Check that the query is a valid SQL where clause
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
if {"" != $where_clause} { set where_clause "and $where_clause" }
# Select SQL: Pull out values.
set sql "
select
aa.object_type||'.'||aa.attribute_name as rest_object_name,
da.attribute_id as rest_oid,
da.*,
aa.*
from im_dynfield_attributes da,
acs_attributes aa
where da.acs_attribute_id = aa.attribute_id
$where_clause
order by
aa.object_type,
aa.attribute_name
"
# Append pagination "LIMIT $limit OFFSET $start" to the sql.
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
set result ""
set obj_ctr 0
db_foreach objects $sql {
# Check permissions
set read_p $rest_otype_read_all_p
if {!$read_p} { continue }
set url "$base_url/$rest_otype/$rest_oid"
switch $format {
html {
append result "
\n"
}
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
eval "set a $$v"
regsub -all {\n} $a {\n} a
regsub -all {\r} $a {} a
append dereferenced_result ", \"$v\": \"[im_quotejson $a]\""
}
append result "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[im_quotejson $rest_object_name]\"$dereferenced_result}"
}
default {}
}
incr obj_ctr
}
switch $format {
html {
set page_title "object_type: $rest_otype"
im_rest_doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
object_id
Link
$result
[im_footer]
"
}
json {
set result "{\"success\": true,\n\"total\": $obj_ctr,\n\"message\": \"im_rest_get_im_dynfield_attributes: Data loaded\",\n\"data\": \[\n$result\n\]\n}"
im_rest_doc_return 200 "application/json" $result
return
}
}
return
}
ad_proc -private im_rest_get_im_indicator_result_interval {
{ -format "xml" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -query_hash_pairs {} }
{ -rest_oid ""}
{ -debug 0 }
} {
Handler for GET rest calls on indicator results
} {
# Note: var "result" had been replaced with "output" since it is used in table im_indicator_results
ns_log Notice "im_rest_get_im_indicator_result_interval: format=$format, user_id=$rest_user_id, rest_otype=$rest_otype, query_hash=$query_hash_pairs"
array set query_hash $query_hash_pairs
set base_url "[im_rest_system_url]/intranet-rest"
set rest_indicator_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = 'im_indicator'" -default 0]]
set rest_otype_read_all_p [im_object_permission -object_id $rest_indicator_otype_id -user_id $rest_user_id -privilege "read"]
# Get locate for translation
set locale [lang::user::locale -user_id $rest_user_id]
# -------------------------------------------------------
# Valid variables to return indicators
set valid_vars {result_id result_indicator_id result_date result_date_pretty result result_count result_system_key result_sector_id result_company_size result_geo_region_id result_object_id}
# -------------------------------------------------------
# Check if there is a where clause specified in the URL and validate the clause.
set where_clause ""
if {[info exists query_hash(query)]} { set where_clause $query_hash(query)}
# -------------------------------------------------------
# Check if there are "valid_vars" specified in the HTTP header
# and add these vars to the SQL clause
set where_clause_list [list]
foreach v $valid_vars {
if {[info exists query_hash($v)]} { lappend where_clause_list "$v=$query_hash($v)" }
}
if {"" != $where_clause && [llength $where_clause_list] > 0} { append where_clause " and " }
append where_clause [join $where_clause_list " and "]
# Check that the query is a valid SQL where clause
set valid_sql_where [im_rest_valid_sql -string $where_clause -variables $valid_vars]
if {!$valid_sql_where} {
im_rest_error -format $format -http_status 403 -message "The specified query is not a valid SQL where clause: '$where_clause'"
return
}
if {"" != $where_clause} { set where_clause "and $where_clause" }
# Single Object?
set where_clause_oid ""
if { "" != $rest_oid } { set where_clause_oid "and result_id = :rest_oid" }
# Select SQL: Pull out categories.
set sql "
select
result_id as rest_oid,
to_char(r.result_date, 'YYYY-MM-DD') as result_date_pretty,
r.*
from
im_indicator_results r
where
1=1
$where_clause
$where_clause_oid
order by
result_id
"
# Append pagination "LIMIT $limit OFFSET $start" to the sql
set unlimited_sql $sql
append sql [im_rest_object_type_pagination_sql -query_hash_pairs $query_hash_pairs]
set value ""
set output ""
set obj_ctr 0
db_foreach objects $sql {
# Calculate indent
# set indent [expr [string length tree_sortkey] - 8]
# Check permissions
set read_p $rest_otype_read_all_p
set read_p 1
if {!$read_p} { continue }
set url "$base_url/$rest_otype/$rest_oid"
switch $format {
xml { append output "$result_id\n" }
html {
append output "
$rest_oid
$result_indicator_id
$result_date_pretty
$result
$result_count
$result_system_key
$result_sector_id
$result_company_size
$result_geo_region_id
$result_object_id
\n"
}
json {
set komma ",\n"
if {0 == $obj_ctr} { set komma "" }
set dereferenced_result ""
foreach v $valid_vars {
eval "set a $$v"
regsub -all {\n} $a {\n} a
regsub -all {\r} $a {} a
append dereferenced_result ", \"$v\": \"[ns_quotehtml $a]\""
}
append output "$komma{\"id\": \"$rest_oid\", \"object_name\": \"[ns_quotehtml $result_id]\"$dereferenced_result}"
}
default {}
}
incr obj_ctr
}
switch $format {
html {
set page_title "object_type: $rest_otype"
im_rest_doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
object_id
result_indicator_id
date
result
result_count
result_system_key
result_sector_id
result_company_size
result_geo_region_id
result_object_id
$output
[im_footer]
"
return
}
xml {
im_rest_doc_return 200 "text/xml" "\n\n$output\n"
return
}
json {
# Deal with different JSON variants for different AJAX frameworks
set output "{\"success\": true,\n\"message\": \"im_rest_get_im_indicator_result_interval: Data loaded\",\n\"data\": \[\n$output\n\]\n}"
im_rest_doc_return 200 "text/html" $output
return
}
}
return
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-init.tcl 0000664 0000000 0000000 00000001340 13175625757 0022046 0 ustar 00root root 0000000 0000000 ad_library {
Initialization for intranet-rest module
@author Frank Bergmann (frank.bergmann@project-open.com)
@creation-date 10 May, 2011
@cvs-id $Id$
}
# Register handler procedures for the various HTTP methods
ad_register_proc GET /intranet-rest/* im_rest_call_get
ad_register_proc POST /intranet-rest/* im_rest_call_post
if {[catch {
ad_register_proc PUT /intranet-rest/* im_rest_call_put
ad_register_proc DELETE /intranet-rest/* im_rest_call_delete
} err_msg]} {
ns_log Error "intranet-rest-init: Error initializing PUT or DELETE verbs: $err_msg"
}
# Create a global cache for im_rest entries
# The cache is bound by global timeout of 1 hour currently.
ns_cache create im_rest -timeout 3600
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-post-procs.tcl 0000664 0000000 0000000 00000040626 13175625757 0023226 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-post-procs.tcl
#
# Copyright (C) 2009 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Component Library
@author frank.bergmann@project-open.com
}
# --------------------------------------------------------
# POST on the object type - CREATE
# --------------------------------------------------------
ad_proc -private im_rest_post_object_type {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for POST rest calls to an object type - create a new object.
} {
ns_log Notice "im_rest_post_object_type: format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, rest_oid=$rest_oid, query_hash=$query_hash_pairs"
set base_url "[im_rest_system_url]/intranet-rest"
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = '$rest_otype'" -default 0]]
set rest_otype_write_all_p [im_object_permission -object_id $rest_otype_id -user_id $rest_user_id -privilege "create"]
# Get the content of the HTTP POST request
set content [im_rest_get_content]
ns_log Notice "im_rest_post_object_type: content='$content'"
# Switch to object specific procedures for handling new object creation
# Check if the procedure exists.
ns_log Notice "im_rest_post_object_type: $rest_otype: [llength [info commands im_rest_post_object_type_$rest_otype]]"
if {0 != [llength [info commands im_rest_post_object_type_$rest_otype]]} {
ns_log Notice "im_rest_post_object_type: Before calling im_rest_post_object_type_$rest_otype"
array set hash_array [eval [list im_rest_post_object_type_$rest_otype \
-format $format \
-rest_user_id $rest_user_id \
-content $content \
-rest_otype $rest_otype \
]]
# Extract the object's id from the return array and write into object_id in case a client needs the info
if {![info exists hash_array(rest_oid)]} {
# Probably after an im_rest_error
ns_log Error "im_rest_post_object_type: Didn't find hash_array(rest_oid): This should never happened"
}
set rest_oid $hash_array(rest_oid)
set hash_array(object_id) $rest_oid
ns_log Notice "im_rest_post_object_type: After calling im_rest_post_object_type_$rest_otype: rest_oid=$rest_oid, hash_array=[array get hash_array]"
switch $format {
html {
set page_title "object_type: $rest_otype"
doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
Object ID
$rest_oid
[im_footer]
"
}
json {
# Return a JSON structure with all fields of the object.
set data_list [list]
foreach key [array names hash_array] {
set value $hash_array($key)
lappend data_list "\"$key\": \"[im_quotejson $value]\""
}
set data "\[{[join $data_list ", "]}\]"
set result "{\"success\": \"true\",\"message\": \"Object created\",\"data\": $data}"
doc_return 200 "application/json" $result
}
default {
ad_return_complaint 1 "Invalid format6: '$format'"
}
}
} else {
ns_log Notice "im_rest_post_object_type: Create for '$rest_otype' not implemented yet"
im_rest_error -format $format -http_status 404 -message "Object creation for object type '$rest_otype' not implemented yet."
return
}
return
}
# --------------------------------------------------------
# DELETE
# --------------------------------------------------------
ad_proc -private im_rest_post_object {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for POST rest calls to an individual object:
Update the specific object using a generic update procedure
} {
ns_log Notice "im_rest_post_object: rest_otype=$rest_otype, rest_oid=$rest_oid, rest_user_id=$rest_user_id, format='$format', query_hash=$query_hash_pairs"
# Get the content of the HTTP POST request
set content [im_rest_get_content]
ns_log Notice "im_rest_post_object: content='$content'"
# Check the REST level permissions on the object type
set rest_otype_id [util_memoize [list db_string otype_id "select object_type_id from im_rest_object_types where object_type = '$rest_otype'" -default 0]]
set write_p [im_object_permission -object_id $rest_otype_id -user_id $rest_user_id -privilege "write"]
if {!$write_p} {
set msg "im_rest_post_object: User #$rest_user_id has no 'write' permission in general on object type '$rest_otype' - please check your REST permissions"
im_rest_error -format $format -http_status 403 -message $msg
return
}
# Check if there is an object type specific permission checker
set write_p 0
if {0 != [llength [info commands ${rest_otype}_permissions]]} {
ns_log Notice "im_rest_post_object: found permission proc ${rest_otype}_permissions - evaluating permissions"
catch {
eval "${rest_otype}_permissions $rest_user_id $rest_oid view_p read_p write_p admin_p"
}
} else {
ns_log Notice "im_rest_post_object: Did not find permission proc ${rest_otype}_permissions - POST permissions denied"
}
if {!$write_p} {
im_rest_error -format $format -http_status 403 -message "User #$rest_user_id has no write permission on object #$rest_oid"
return
}
# Check if there is a customized version of this post handler
if {0 != [llength [info commands im_rest_post_object_$rest_otype]]} {
ns_log Notice "im_rest_post_object: found a customized POST handler for rest_otype=$rest_otype, rest_oid=$rest_oid, query_hash=$query_hash_pairs"
set rest_oid [eval [list im_rest_post_object_$rest_otype \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
-debug $debug \
-content $content \
]]
}
# Parse the HTTP content
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
# Audit + Callback before updating the object
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action before_update
# Update the object. This routine will return a HTTP error in case
# of a database constraint violation
ns_log Notice "im_rest_post_object: Before im_rest_object_type_update_sql"
im_rest_object_type_update_sql \
-format $format \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
ns_log Notice "im_rest_post_object: After im_rest_object_type_update_sql"
# Audit + Callback after updating the object
im_audit -user_id $rest_user_id -object_type $rest_otype -object_id $rest_oid -action after_update
# The update was successful - return a suitable message.
switch $format {
html {
set page_title "object_type: $rest_otype"
doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
Object ID
$rest_oid
[im_footer]
"
}
json {
# Empty data: The empty array is necessary for Sencha in order to call callbacks
# without error. However, adding data here will create empty records in the store later,
# so the array needs to be empty.
set data_list [list]
foreach key [array names hash_array] {
set value $hash_array($key)
lappend data_list "\"$key\": \"[im_quotejson $value]\""
}
set data "\[{[join $data_list ", "]}\]"
set result "{\"success\": \"true\",\"message\": \"Object updated\",\"data\": $data}"
doc_return 200 "application/json" $result
}
}
return
}
# --------------------------------------------------------
# im_hours
#
# Update operation. This is implemented here, because
# im_hour isn't a real object
ad_proc -private im_rest_post_object_im_hour {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -content "" }
{ -debug 0 }
{ -query_hash_pairs ""}
} {
Handler for POST calls on particular im_hour objects.
im_hour is not a real object type and performs a "delete"
operation specifying hours=0 or hours="".
} {
ns_log Notice "im_rest_post_object_im_hour: rest_oid=$rest_oid"
# Permissions
# ToDo
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
set $key $value
}
set hours $hash_array(hours)
set hour_id $hash_array(hour_id)
if {"" == $hours || 0.0 == $hours} {
# Delete the hour instead of updating it.
# im_hours is not a real object, so we don't need to
# cleanup acs_objects.
ns_log Notice "im_rest_post_object_im_hour: deleting hours because hours='$hours', hour_id=$hour_id"
db_dml del_hours "delete from im_hours where hour_id = :hour_id"
} else {
# Update the object. This routine will return a HTTP error in case
# of a database constraint violation
ns_log Notice "im_rest_post_object_im_hour: Before updating hours=$hours with hour_id=$hour_id"
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
ns_log Notice "im_rest_post_object_im_hour: After updating hours=$hours with hour_id=$hour_id"
}
# The update was successful - return a suitable message.
switch $format {
html {
set page_title "object_type: $rest_otype"
doc_return 200 "text/html" "
[im_header $page_title][im_navbar]
Object ID
$rest_oid
[im_footer]
"
}
json {
set data_list [list]
foreach key [array names hash_array] {
set value $hash_array($key)
lappend data_list "\"$key\": \"[im_quotejson $value]\""
}
set data "\[{[join $data_list ", "]}\]"
set result "{\"success\": \"true\",\"message\": \"Object updated\",\"data\": $data}"
doc_return 200 "application/json" $result
}
}
}
# --------------------------------------------------------
# im_hour_intervals
#
# Update operation. This is implemented here, because
# im_hour_interval isn't a real object
ad_proc -private im_rest_post_object_im_hour_interval {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -content "" }
{ -debug 0 }
{ -query_hash_pairs ""}
} {
Handler for POST calls on particular im_hour_interval objects.
im_hour_interval is not a real object type and performs a "delete"
operation when interval_start = interval_end
} {
ns_log Notice "im_rest_post_object_im_hour_interval: rest_oid=$rest_oid"
# Permissions
# ToDo
# Extract a key-value list of variables from JSON POST request
array set hash_array [im_rest_parse_json_content -rest_otype $rest_otype -format $format -content $content]
ns_log Notice "im_rest_post_object_$rest_otype: hash_array=[array get hash_array]"
# write hash values as local variables
foreach key [array names hash_array] {
set value $hash_array($key)
set $key $value
}
set interval_id $hash_array(interval_id)
if {$interval_start == $interval_end} {
# Delete the hour_interval instead of updating it.
# im_hour_intervals is not a real object, so we don't need to
# cleanup acs_objects.
ns_log Notice "im_rest_post_object_im_hour_interval: deleting hours because interval_start = interval_end = $interval_start', interval_id=$interval_id"
db_dml del_hours "delete from im_hour_intervals where interval_id = :interval_id"
} else {
# Update the object. This routine will return a HTTP error in case
# of a database constraint violation
ns_log Notice "im_rest_post_object_im_hour_interval: Before updating interval_id=$interval_id"
im_rest_object_type_update_sql \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-hash_array [array get hash_array]
ns_log Notice "im_rest_post_object_im_hour_interval: After updating interval_id=$interval_id"
}
# The update was successful - return a suitable message.
switch $format {
html {
set page_title "object_type: $rest_otype"
doc_return 200 "text/html" "
[im_header $page_title][im_navbar]
Object ID
$rest_oid
[im_footer]
"
}
json {
set data_list [list]
foreach key [array names hash_array] {
set value $hash_array($key)
lappend data_list "\"$key\": \"[im_quotejson $value]\""
}
set data "\[{[join $data_list ", "]}\]"
set result "{\"success\": \"true\",\"message\": \"Object updated\",\"data\": $data}"
doc_return 200 "application/json" $result
}
}
}
# --------------------------------------------------------
# DELETE
# --------------------------------------------------------
ad_proc -private im_rest_delete_object {
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for DELETE rest calls to an individual object:
Update the specific object using a generic update procedure
} {
set content [im_rest_get_content]
ns_log Notice "im_rest_delete_object: rest_otype=$rest_otype, rest_oid=$rest_oid, rest_user_id=$rest_user_id, format='$format', query_hash=$query_hash_pairs, content=$content"
# Deletion requires administrator rights or admin_p permissions
set admin_p [im_user_is_admin_p $rest_user_id]
if {!$admin_p && 0 != [llength [info commands ${rest_otype}_permissions]]} {
catch {
eval "${rest_otype}_permissions $rest_user_id $rest_oid view_p read_p admin_p admin_p"
}
}
if {!$admin_p} {
im_rest_error -format $format -http_status 403 -message "User #$rest_user_id has no 'admin' permission to perform DELETE on object #$rest_oid"
return
}
# Deal with certain subtypes
switch $rest_otype {
im_ticket {
# use im_project_nuke that also serves to delete tickets
set nuke_otype "im_project"
}
default {
set nuke_otype $rest_otype
}
}
# Destroy the object. Try first with an object_type_nuke TCL procedure.
set destroyed_err_msg ""
if {[catch {
set nuke_tcl [list "${nuke_otype}_nuke" -current_user_id $rest_user_id $rest_oid]
ns_log Notice "im_rest_delete_object: nuke_tcl=$nuke_tcl"
eval $nuke_tcl
} err_msg]} {
ns_log Notice "im_rest_delete_object: Error nuking object $rest_oid using TCL code: $err_msg"
set destroyed_p 0
append destroyed_err_msg "$err_msg\n"
} else {
ns_log Notice "im_rest_delete_object: Successfully nuked object $rest_oid using TCL code"
set destroyed_p 1
}
# Then try with a object_type__delete PL/SQL procedure
if {!$destroyed_p} {
if {[catch {
set destructor_name "${nuke_otype}__delete"
set destructor_exists_p [util_memoize [list db_string destructor_exists "select count(*) from pg_proc where lower(proname) = '$destructor_name'"]]
if {$destructor_exists_p} {
ns_log Notice "im_rest_delete_object: About to try to nuke using plsql='select $destructor_name($rest_oid)'"
db_string destruct_object "select $destructor_name($rest_oid) from dual"
}
set destroyed_p 1
ns_log Notice "im_rest_delete_object: Successfully nuked object $rest_oid using PL/SQLL code"
} err_msg]} {
append destroyed_err_msg "$err_msg\n"
ns_log Notice "im_rest_delete_object: Error nuking object $rest_oid using PL/SQL code"
}
}
# Try to destruct the object
if {!$destroyed_p} {
im_rest_error -format $format -http_status 404 -message "DELETE for object #$rest_oid of type \"$rest_otype\" created errors: $destroyed_err_msg"
return
}
# The delete was successful - return a suitable message.
switch $format {
html {
set page_title "object_type: $rest_otype"
doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
Object ID
$rest_oid
[im_footer]
"
}
json {
set result "{\"success\": \"true\",\"message\": \"Object deleted\"}"
doc_return 200 "application/json" $result
}
}
return
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-procs.tcl 0000664 0000000 0000000 00000030777 13175625757 0022251 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-procs.tcl
#
# Copyright (C) 2009 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Component Library
@author frank.bergmann@project-open.com
}
# -------------------------------------------------------
# REST Version
# -------------------------------------------------------
ad_proc -private im_rest_version {} {
Returns the current server version of the REST interface.
Please see www.project-open.com/en/rest-version-history
3.0 (2014-09-11): Removed XML support, changed single object GET,
test based dev, rewrite of read/list
2.2 (2013-10-18): Added "deref_p=1" parameter for dereferencing
2.1 (2012-03-18): Added new report and now deprecating single object calls
2.0 (2011-05-12): Added support for JSOn and Sencha format variants
1.5.2 (2010-12-21): Fixed bug of not applying where_query
1.5.1 (2010-12-01): Fixed bug with generic objects, improved rendering of some fields
1.5 (2010-11-03): Added rest_object_permissions and rest_group_memberships reports
1.3 (2010-04-01): First public version
} {
return "3.0"
}
# -------------------------------------------------------
# HTTP Interface
#
# Deal HTTP parameters, authentication etc.
# -------------------------------------------------------
ad_proc -private im_rest_call_post {} {
Handler for GET rest calls
} {
return [im_rest_call_get -http_method POST]
}
ad_proc -private im_rest_call_put {} {
Handler for PUT rest calls
} {
# set rest_user_id [im_rest_cookie_auth_user_id]
# ns_log Notice "im_rest_call_put: rest_user_id=$rest_user_id"
return [im_rest_call_get -http_method PUT]
}
ad_proc -private im_rest_call_delete {} {
Handler for DELETE rest calls
} {
return [im_rest_call_get -http_method DELETE]
}
ad_proc -private im_rest_call_get {
{-http_method GET }
{-format "json" }
} {
Handler for GET rest calls
} {
ns_log Notice "im_rest_call_get: Starting"
# Get the entire URL and decompose into the "rest_otype"
# and the "rest_oid" pieces. Splitting the URL on "/"
# will result in "{} intranet-rest rest_otype rest_oid":
set url [ns_conn url]
set url_pieces [split $url "/"]
set rest_otype [lindex $url_pieces 2]
set rest_oid [lindex $url_pieces 3]
ns_log Notice "im_rest_call_get: oid=$rest_oid, otype=$rest_otype"
# Get the information about the URL parameters, parse
# them and store them into a hash array.
set query [ns_conn query]
set query_pieces [split $query "&"]
array set query_hash {}
foreach query_piece $query_pieces {
if {[regexp {^([^=]+)=(.+)$} $query_piece match var val]} {
# Additional decoding: replace "+" by " "
regsub -all {\+} $var { } var
regsub -all {\+} $val { } val
set var [ns_urldecode $var]
set val [ns_urldecode $val]
ns_log Notice "im_rest_call_get: var='$var', val='$val'"
set query_hash($var) $val
}
}
if {[info exists query_hash(format)]} { set format $query_hash(format) }
# Determine the authenticated user_id. 0 means not authenticated.
ns_log Notice "im_rest_call_get: before im_rest_authenticate: format=$format, query_hash_pairs=[array get query_hash]"
set auth_hash_list [im_rest_authenticate -format $format -query_hash_pairs [array get query_hash]]
ns_log Notice "im_rest_call_get: after im_rest_authenticate: auth_hash=$auth_hash_list"
array set auth_hash $auth_hash_list
if {0 == [llength [array get auth_hash]]} { return [im_rest_error -format $format -http_status 401 -message "Not authenticated"] }
set auth_user_id $auth_hash(user_id)
set auth_method $auth_hash(method)
ns_log Notice "im_rest_call_get: method=$http_method, format=$format, user_id=$auth_user_id, query_hash=[array get query_hash]"
if {"" == $auth_user_id} { return [im_rest_error -format $format -http_status 401 -message "Not authenticated"] }
# Default format are:
# - "html" for cookie authentication
# - "json" for basic authentication
# - "json" for auth_token authentication
switch $auth_method {
basic { set format "json" }
cookie { set format "html" }
token { set format "json" }
default { return [im_rest_error -format $format -http_status 401 -message "Invalid authentication method '$auth_method'."] }
}
# Overwrite default format with explicitely specified format in URL
if {[info exists query_hash(format)]} { set format $query_hash(format) }
set valid_formats {html json}
if {[lsearch $valid_formats $format] < 0} {
return [im_rest_error -format $format -http_status 406 -message "Invalid output format '$format'. Valid formats include {html|json}."]
}
# Security checks
set alert_p 0
set alert_p [expr {$alert_p || [im_security_alert_check_integer -location "im_rest_call: user_id" -value $auth_user_id]}]
if {"data-source" != $rest_otype} {
set alert_p [expr {$alert_p || [im_security_alert_check_integer -location "im_rest_call: rest_oid" -value $rest_oid]}]
set alert_p [expr {$alert_p || [im_security_alert_check_alphanum -location "im_rest_call: rest_otype" -value $rest_otype]}]
}
if {$alert_p} {
return [im_rest_error -format $format -http_status 500 -message "Internal error: Found a security error, please check your security notifications"]
}
# Call the main request processing routine
if {[catch {
im_rest_call \
-method $http_method \
-format $format \
-rest_user_id $auth_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs [array get query_hash]
} err_msg]} {
append err_msg "\nStack Trace:\n"
append err_msg $::errorInfo
ns_log Notice "im_rest_call_get: im_rest_call returned an error: $err_msg"
return [im_rest_error -format $format -http_status 500 -message "Internal error: $err_msg"]
}
}
ad_proc -private im_rest_page {
{ -rest_otype "index" }
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
The user has requested /intranet-rest/index or /intranet-rest/data-source/*
} {
ns_log Notice "im_rest_page: rest_otype=$rest_otype, rest_oid=$rest_oid, query_hash=$query_hash_pairs"
set params [list \
[list rest_otype $rest_otype] \
[list rest_oid $rest_oid] \
[list format $format] \
[list rest_user_id $rest_user_id] \
[list query_hash_pairs $query_hash_pairs] \
]
set file "/packages/intranet-rest/www/$rest_otype"
if {"data-source" == $rest_otype} {
append file "/$rest_oid"
}
set result [ad_parse_template -params $params $file]
# set result "{success:false, message: 'ad_parse_template -params $params $file'}"
switch $format {
json { set mime_type "application/json" }
default { set mime_type "text/html" }
}
doc_return 200 $mime_type $result
return
}
# -------------------------------------------------------
# REST Call Drivers
# -------------------------------------------------------
ad_proc -private im_rest_call {
{ -method GET }
{ -format "json" }
{ -rest_user_id 0 }
{ -rest_otype "" }
{ -rest_oid "" }
{ -query_hash_pairs {} }
{ -debug 0 }
} {
Handler for all REST calls
} {
ns_log Notice "im_rest_call: method=$method, format=$format, rest_user_id=$rest_user_id, rest_otype=$rest_otype, rest_oid=$rest_oid, query_hash=$query_hash_pairs"
# -------------------------------------------------------
# Special treatment for /intranet-rest/ and /intranet/rest/index URLs
#
if {"" == $rest_otype} { set rest_otype "index" }
set pages {"" index version auto-login dynfield-widget-values "data-source" }
if {[lsearch $pages $rest_otype] >= 0} {
return [im_rest_page \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
# -------------------------------------------------------
# Check the "rest_otype" to be a valid object type
set valid_rest_otypes [util_memoize [list db_list otypes "
select object_type
from acs_object_types
union
select 'im_category'
union
select 'im_indicator_result'
"]]
if {[lsearch $valid_rest_otypes $rest_otype] < 0} {
return [im_rest_error -format $format -http_status 406 -message "Invalid object_type '$rest_otype'. Valid object types include {im_project|im_company|...}."]
}
# -------------------------------------------------------
switch $method {
GET {
# Handle both "read" and "list" operations using the same procedure
switch $rest_otype {
im_indicator_result {
return [im_rest_get_im_indicator_result_interval \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
im_category {
return [im_rest_get_im_categories \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
im_dynfield_attribute {
return [im_rest_get_im_dynfield_attributes \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
im_hour {
return [im_rest_get_im_hours \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
im_hour_interval {
return [im_rest_get_im_hour_intervals \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
im_invoice_item {
return [im_rest_get_im_invoice_items \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
im_timesheet_task_dependency {
return [im_rest_get_im_timesheet_task_dependencies \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
default {
# Return query from the object rest_otype
return [im_rest_get_object_type \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs \
]
}
}
}
POST - PUT {
# Is the post operation performed on a particular object or on the object_type?
if {"" != $rest_oid} {
# POST with object_id => Update operation on an object
ns_log Notice "im_rest_call: Found a POST operation on object_type=$rest_otype with object_id=$rest_oid"
im_rest_post_object \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs
} else {
# POST without object_id => Update operation on the "factory" object_type
ns_log Notice "im_rest_call: Found a POST operation on object_type=$rest_otype"
im_rest_post_object_type \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-query_hash_pairs $query_hash_pairs
}
}
DELETE {
# Is the post operation performed on a particular object or on the object_type?
if {"" != $rest_oid && 0 != $rest_oid} {
# DELETE with object_id => delete operation
ns_log Notice "im_rest_call: Found a DELETE operation on object_type=$rest_otype with object_id=$rest_oid"
im_rest_delete_object \
-format $format \
-rest_user_id $rest_user_id \
-rest_otype $rest_otype \
-rest_oid $rest_oid \
-query_hash_pairs $query_hash_pairs
} else {
# DELETE without object_id is not allowed - you can only destroy a known object
ns_log Error "im_rest_call: You have to specify an object to DELETE."
return [im_rest_error -format $format -http_status 500 -message "You have to specify an object to DELETE."]
}
}
default {
return [im_rest_error -format $format -http_status 400 -message "Unknown HTTP request '$method'. Valid requests include {GET|POST|PUT|DELETE}."]
}
}
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-sql-parser-procs.tcl 0000664 0000000 0000000 00000066330 13175625757 0024332 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-sql-parser.tcl
#
# Copyright (C) 2009 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Library
Utility functions
@author frank.bergmann@project-open.com
}
# ----------------------------------------------------------------------
# SQL Validator
# ----------------------------------------------------------------------
ad_proc -public im_rest_valid_sql {
-string:required
{-variables {} }
{-debug 1}
} {
Returns 1 if "where_clause" is a valid where_clause or 0 otherwise.
ToDo:
Single quote quoting: Does not handle correctly
} {
# An empty string is a valid SQL...
if {"" == $string} { return 1 }
# ------------------------------------------------------
# Massage the string so that it suits the rule engine.
# Reduce all characters to lower case
set string [string tolower $string]
# Add spaces around the string
set string " $string "
# Add an extra space between all "comparison" strings in the where clause
regsub -all {([\>\<\=\!]+)} $string { \1 } string
# Add an extra space around parentesis
regsub -all {([\(\)])} $string { \1 } string
# Add an extra space around kommas
regsub -all {(,)} $string { \1 } string
# Replace multiple spaces by a single one
regsub -all {\s+} $string { } string
# Eliminate leading space
if {" " == [string range $string 0 0]} { set string [string range $string 1 end] }
set result [sql_search_condition $string]
set parsed_term [lindex $result 0]
set remaining_string [string trim [lindex $result 1]]
set error_message [lindex $result 2]
# ad_return_complaint 1 "
parsed=$parsed_term\nrem=$remaining_string\nerr=$error_message"
if {"" == $remaining_string} {
# Nothing remaining - everything is parsed correctly
return 1
} else {
# Something is left - error
return 0
}
}
# ----------------------------------------------------------------------
# SQL Parser
# ----------------------------------------------------------------------
ad_proc -public sql_select {str} {
ns_log Notice "sql_select: $str"
set str_org $str
if {"select" != [lindex $str 0]} { return [list "" $str_org "Not a select - 'select' expected as first literal"] }
set str [lrange $str 1 end]
# [ DISTINCT | ALL ]
set s0 [lindex $str 0]
if {"distinct" == $s0 || "all" == $s0} {
set str [lrange $str 1 end]
}
# ( '*' | functions | value_litteral { ',' value_litteral } )
set continue 1
set select_cols [list]
while {$continue} {
set s0 [sql_exact $str "*"]
if {"" == [lindex $s0 0]} { set s0 [sql_function_count $str] }
if {"" == [lindex $s0 0]} { set s0 [sql_function $str] }
if {"" == [lindex $s0 0]} { set s0 [sql_value_litteral $str] }
if {"" == [lindex $s0 0]} { return [list "" $str_org "Select - expecting '*', function or literal"] }
lappend select_cols [lindex $s0 0]
set str [lindex $s0 1]
set komma [sql_exact $str ","]
set str [lindex $komma 1]
if {"," != [lindex $komma 0]} { set continue 0 }
}
# 'from' from_table_reference { ',', from_table_reference}
set from [sql_exact $str "from"]
if {"" == [lindex $from 0]} { return [list "" $str_org "Select - expecting 'from'"] }
set str [lindex $from 1]
set t0 [sql_from_table_reference $str]
set str [lindex $t0 1]
if {"" == [lindex $t0 0]} { return [list "" $str_org "Select - expecting table reference after 'from'"] }
set table_references [list [lindex $t0 0]]
set komma [sql_exact $str ","]
set str [lindex $komma 1]
while {"," == [lindex $komma 0]} {
set t1 [sql_from_table_reference $str]
if {"" == [lindex $t1 0]} { return [list "" $str_org "Select - expecting table reference after ','"] }
set str [lindex $t1 1]
lappend table_references $t1
set komma [sql_exact $str ","]
set str [lindex $komma 1]
}
# [ 'where' search_condition ]
set where [sql_exact $str "where"]
set str [lindex $where 1]
set search_condition ""
if {"" != [lindex $where 0]} {
set search_condition [sql_search_condition $str]
if {"" == [lindex $search_condition 0]} { return [list "" $str_org "Select - expecting search_condition after 'where'"] }
set str [lindex $search_condition 1]
}
return [list [list select $select_cols $table_references [lindex $search_condition 0]] $str ""]
}
# search_condition = search_value { ( 'or' | 'and' ) search_condition }.
ad_proc -public sql_search_condition {str} {
ns_log Notice "sql_search_condition: '$str'"
set conditions [list]
set continue 1
while {$continue} {
set s0 [sql_search_value $str]
if {"" == [lindex $s0 0]} { return [list "" $str "Not a search_condition - expecting a search_value"] }
set str [lindex $s0 1]
lappend conditions [lindex $s0 0]
set conj [sql_exact $str "and"]
if {"" == [lindex $conj 0]} { set conj [sql_exact $str "or"] }
set str [lindex $conj 1]
if {"" == [lindex $conj 0]} { set continue 0 }
}
return [list $conditions $str ""]
}
# search_value =
# value_litteral [ 'not' ] ( between | like | in | compare | containing | starting ) |
# 'is' [ 'not' ] 'null' |
# ('all' | 'some' | 'any') '(' select_column_list ')' |
# 'exists' '(' select_expression ')' |
# 'singular' '(' select_expression ')' |
# '(' search_condition ')' |
# 'not' search_condition.
ad_proc -public sql_search_value {str} {
ns_log Notice "sql_search_value: $str"
set str_org $str
# Search for simple keyword to start with
set kw [lindex $str 0]
switch $kw {
"(" {
# '(' search_condition ')'
set str [lrange $str 1 end]
set s0 [sql_search_condition $str]
if {"" == [lindex $s0 0]} { return [list "" $str_org "Not a search value - expecting search_condition after '('"] }
set str [lindex $s0 1]
set par [sql_exact $str ")"]
if {"" == [lindex $par 0]} { return [list "" $str_org "Not a search value - expecting ')' after search_condition"] }
set str [lindex $par 1]
return [list [lindex $s0 0] $str ""]
}
"not" {
# 'not' search_condition
set str [lrange $str 1 end]
set s0 [sql_search_condition $str]
if {"" == [lindex $s0 0]} { return [list "" $str_org "Not a search value - expecting search_condition after 'not'"] }
set str [lindex $s0 1]
return [list [list "not" [lindex $s0 0]] $str ""]
}
"is" {
# 'is' [ 'not' ] 'null' |
set str [lrange $str 1 end]
# Optional 'not' - simply ignore error of sql_exact
set not [sql_exact $str "not"]
set str [lindex $not 1]
set null [sql_exact $str "null"]
if {"" == [lindex $null 0]} { return [list "" $str_org "Not a search value - expecting 'null' after 'is'"] }
set str [lindex $null 1]
return [list "is [lindex $not 0] null" $str ""]
}
}
# value_litteral [ 'not' ] ( between | like | in | compare | containing | starting ) |
set v0 [sql_value_litteral $str]
if {"" != [lindex $v0 0]} {
set str [lindex $v0 1]
# Optional 'not' - simply ignore error of sql_exact
set not [sql_exact $str "not"]
set str [lindex $not 1]
set cont [list ""]
set kw [lindex $str 0]
set op [sql_operator $str]
if {"" != [lindex $op 0]} { set kw "compare" }
switch $kw {
"between" {
set cont [sql_between $str]
if {"" == [lindex $cont 0]} { return [list "" $str_org "Not a search_value - invalid 'between' clause"] }
}
"compare" {
set cont [sql_compare $str]
if {"" == [lindex $cont 0]} { return [list "" $str_org "Not a search_value - invalid 'compare' clause"] }
}
"containing" {
set cont [sql_containing $str]
if {"" == [lindex $cont 0]} { return [list "" $str_org "Not a search_value - invalid 'containing' clause"] }
}
"in" {
set cont [sql_in $str]
if {"" == [lindex $cont 0]} { return [list "" $str_org "Not a search_value - invalid 'in' clause"] }
}
"is" {
# 'is' [ 'not' ] 'null' |
set str [lrange $str 1 end]
# Optional 'not' - simply ignore error of sql_exact
set not [sql_exact $str "not"]
set str [lindex $not 1]
set null [sql_exact $str "null"]
if {"" == [lindex $null 0]} { return [list "" $str_org "Not a search value - expecting 'null' after 'is'"] }
set str [lindex $null 1]
return [list "is [lindex $not 0] null" $str ""]
}
"like" {
set cont [sql_like $str]
if {"" == [lindex $cont 0]} { return [list "" $str_org "Not a search_value - invalid 'like' clause"] }
}
"starting" {
set cont [sql_starting $str]
if {"" == [lindex $cont 0]} { return [list "" $str_org "Not a search_value - invalid 'starting' clause"] }
}
default {
return [list "" $str_org "Not a search_value - expecting between, like, in, compare, containing or starting after value_litteral, found '$kw'"]
}
}
set str [lindex $cont 1]
return [list [list litteral [lindex $v0 0] not [lindex $not 0] $kw [lindex $cont 0]] $str ""]
}
return [list "" $str "Not a search value - found none of the options"]
}
# like = 'like' value_litteral [ ESCAPE value_litteral ].
ad_proc -public sql_like {str} {
ns_log Notice "sql_like: $str"
set str_org $str
set like [sql_exact $str "like"]
if {"" == [lindex $like 0]} { return [list "" $str_org "Not a like - 'like' expected as first literal"] }
set str [lindex $like 1]
set val [sql_value_litteral $str]
if {"" == [lindex $val 0]} { return [list "" $str_org "Not a like - value_litteral expected after 'like'"] }
set str [lindex $val 1]
return [list [list like [lindex $val 0]] $str ""]
}
# containing = 'containing' value_litteral .
ad_proc -public sql_containing {str} {
ns_log Notice "sql_containing: $str"
set str_org $str
set containing [sql_exact $str "containing"]
if {"" == [lindex $containing 0]} { return [list "" $str_org "Not a containing - 'containing' expected as first literal"] }
set str [lindex $containing 1]
set val [sql_value_litteral $str]
if {"" == [lindex $val 0]} { return [list "" $str_org "Not a containing - value_litteral expected after 'containing'"] }
set str [lindex $val 1]
return [list [list containing [lindex $val 0]] $str ""]
}
# starting = 'starting' value_litteral .
ad_proc -public sql_starting {str} {
ns_log Notice "sql_starting: $str"
set str_org $str
set starting [sql_exact $str "starting"]
if {"" == [lindex $starting 0]} { return [list "" $str_org "Not a starting - 'starting' expected as first literal"] }
set str [lindex $starting 1]
set val [sql_value_litteral $str]
if {"" == [lindex $val 0]} { return [list "" $str_org "Not a starting - value_litteral expected after 'starting'"] }
set str [lindex $val 1]
return [list [list starting [lindex $val 0]] $str ""]
}
# in = 'in' '(' value_litteral { ',' value_litteral } | select_column_list ')'.
ad_proc -public sql_in {str} {
ns_log Notice "sql_in: $str"
set str_org $str
set in [sql_exact $str "in"]
if {"" == [lindex $in 0]} { return [list "" $str_org "Not a in - 'in' expected as first literal"] }
set str [lindex $in 1]
set par [sql_exact $str "("]
if {"" == [lindex $par 0]} { return [list "" $str_org "Not a in - '(' expected as second literal"] }
set str [lindex $par 1]
set kw [lindex $str 0]
switch $kw {
"select" {
# Check for select_column_list
set collist [sql_select $str]
set str [lindex $collist 1]
if {"" == [lindex $collist 0]} { return [list "" $str_org "Not a in - valid select statement expected after 'in' '(' 'select'"] }
set result [list in_collist [lindex $collist 0]]
}
default {
# Check for list of value_litterals
set continue 1
set values [list]
while {$continue} {
set val [sql_value_litteral $str]
if {"" == [lindex $val 0]} { return [list "" $str_org "Not a in - invalid value_litteral in list of values"] }
lappend values [lindex $val 0]
set str [lindex $val 1]
set komma [sql_exact $str ","]
set str [lindex $komma 1]
if {"," != [lindex $komma 0]} { set continue 0 }
}
set result [list in_valuelist $values]
}
}
set par [sql_exact $str ")"]
if {"" == [lindex $par 0]} { return [list "" $str_org "Not a in - ')' expected after last value_litteral"] }
set str [lindex $par 1]
return [list $result $str ""]
}
# between = 'between' value_litteral 'and' value_litteral.
ad_proc -public sql_between {str} {
ns_log Notice "sql_between: $str"
if {"between" != [lindex $str 0]} { return [list "" $str "Not a between - 'between' expected as first literal"] }
set str [lrange $str 1 end]
set b1 [sql_value_litteral $str]
if {"" == [lindex $b1 0]} { return [list "" $str "Not a between - literal expected as 2nd literal"] }
set str [lindex $b1 1]
if {"and" != [lindex $str 0]} { return [list "" $str "Not a between - 'and' expected as 3rd literal"] }
set str [lrange $str 1 end]
set b2 [sql_value_litteral $str]
if {"" == [lindex $b2 0]} { return [list "" $str "Not a between - literal expected as 4th literal"] }
set str [lindex $b2 1]
return [list [list between [lindex $b1 0] and [lindex $b2 0]] $str ""]
}
# from_table_reference = name [ procedure_end ] [ alias_name ] | joined_table.
ad_proc -public sql_from_table_reference {str} {
ns_log Notice "sql_from_table_reference: $str"
set name [sql_name $str]
if {"" == [lindex $name 0]} { return [list "" $str "Not a from_table_reference - expecting a name as first literal"] }
set str [lindex $name 1]
set procedure_end [sql_procedure_end $str]
set str [lindex $procedure_end 1]
# Optional alias
set alias [sql_name $str]
set str [lindex $alias 1]
return [list [list name [lindex $name 0] procedure_end [lindex $procedure_end 0] alias [lindex $alias 0]] $str ""]
}
# procedure_end= '(' value_litteral { ',' value_litteral } ')' .
ad_proc -public sql_procedure_end {str} {
# ns_log Notice "sql_procedure_end: $str"
set str_org $str
set par_open [sql_exact $str "("]
if {"" == [lindex $par_open 0]} { return [list "" $str_org "Not a procedure_end - expecting '(' as first literal"] }
set str [lrange $str 1 end]
set v0 [sql_value_litteral $str]
set values [list [lindex $v0 0]]
if {"" == [lindex $v0 0]} { return [list "" $str_org "Not a procedure_end - expecting literal after '('"] }
set str [lindex $v0 1]
set komma [sql_exact $str ","]
while {"," == [lindex $komma 0]} {
set str [lindex $komma 1]
set v1 [sql_value_litteral $str]
if {"" == [lindex $v1 0]} { return [list "" $str_org "Not a procedure_end - found non-literal between '(' and ')'"] }
set str [lindex $v1 1]
lappend values [lindex $v1 0]
set komma [sql_exact $str ","]
}
set str [lindex $komma 1]
set par_close [sql_exact $str ")"]
if {"" == [lindex $par_close 0]} { return [list "" $str_org "Not a procedure_end - expecting ')' as last literal"] }
set str [lindex $par_close 1]
return [list $values $str ""]
}
# compare = operator ( value_litteral | '(' select_one_column ')' ) .
ad_proc -public sql_compare {str} {
ns_log Notice "sql_compare: $str"
set str_org $str
set op [sql_operator $str]
if {"" == [lindex $op 0]} { return [list "" $str_org "Compare - expecting operator as first token"] }
set str [lindex $op 1]
# Try value_litteral after operator
set val [sql_value_litteral $str]
set str [lindex $val 1]
if {"" != [lindex $val 0]} {
return [list [list operator [lindex $op 0] value [lindex $val 0]] $str ""]
}
# Otherwise go for select
set par [sql_exact $str "("]
set str [lindex $par 1]
if {"" == [lindex $par 0]} { return [list "" $str_org "Compare - expecting '(' or value_litteral after operator"] }
set sel [sql_select $str]
set str [lindex $sel 1]
if {"" == [lindex $sel 0]} { return [list "" $str_org "Compare - expecting select after '('"] }
return [list [list operator [lindex $op 0] select [lindex $sel 0]] $str ""]
}
# function_count = count ( * )
ad_proc -public sql_function_count {str} {
ns_log Notice "sql_function_count: $str"
set name [sql_name $str]
if {"count" != [lindex $name 0]} { return [list "" $str "Not a count function - expecting 'count' as first literal"] }
set str [lindex $name 1]
set par_open [sql_exact $str "("]
if {"" == [lindex $par_open 0]} { return [list "" $str "Not a count function - expecting '(' after 'count'"] }
set str [lrange $str 1 end]
set asterisk [sql_exact $str "*"]
if {"*" != [lindex $asterisk 0]} { return [list "" $str "Not a count function - expecting '*' after 'count(' "] }
set str [lrange $str 1 end]
set par_close [sql_exact $str ")"]
if {"" == [lindex $par_close 0]} { return [list "" $str "Not a procedure_end - expecting ')' as last literal"] }
set str [lindex $par_close 1]
return [list [list function [lindex $name 0] procedure_end "*"] $str ""]
}
# function = name procedure_end
ad_proc -public sql_function {str} {
ns_log Notice "sql_function: $str"
set name [sql_name $str]
if {"" == [lindex $name 0]} { return [list "" $str "Not a function - expecting a name as first literal"] }
set str [lindex $name 1]
set procedure_end [sql_procedure_end $str]
if {"" == [lindex $procedure_end 0]} { return [list "" $str "Not a function - expecting a procedure_end after name"] }
set str [lindex $procedure_end 1]
return [list [list function [lindex $name 0] procedure_end [lindex $procedure_end 0]] $str ""]
}
ad_proc -public sql_value_litteral {str} {
ns_log Notice "sql_value_litteral: $str"
set str_org $str
set first_char [string range $str 0 0]
if {[string is integer $first_char]} { set first_char "integer" }
if {"-" == $first_char} {
# Deal with negative integers - ugly/inconsistent?
set str [string range $str 1 end]
set first_char "integer"
}
if {[string is alpha $first_char]} { set first_char "alpha" }
switch $first_char {
"'" {
# Search for ending tick
set lit ""
set str [string range $str 1 end]
set char [string range $str 0 0]
set cnt 0
while {$cnt < 1000 && "'" != $char && $str ne ""} {
append lit $char
set str [string range $str 1 end]
set char [string range $str 0 0]
incr cnt
}
if {"'" != $char} { return [list "" $str "Value litteral - found invalid value litteral"] }
set str [string range $str 1 end]
# Skip whitespaces after tick
set cnt 0
set char [string range $str 0 0]
while {$cnt < 1000 && " " == $char && $str ne ""} {
set str [string range $str 1 end]
set char [string range $str 0 0]
incr cnt
}
return [list $lit $str ""]
}
"integer" {
set int [sql_integer $str]
if {"" == [lindex $int 0]} { return [list "" $str_org "Value litteral - found bad integer"] }
return $int
}
"alpha" {
set alpha [sql_name $str]
if {"" == [lindex $alpha 0]} { return [list "" $str_org "Value litteral - found bad name"] }
set str [lindex $alpha 1]
set procedure_end [sql_procedure_end $str]
set str [lindex $procedure_end 1]
if {"" == [lindex $procedure_end 0]} {
return $alpha
} else {
return [list [list function [lindex $alpha 0] [lindex $procedure_end 0]] $str ""]
}
}
default {
return [list "" $str_org "Value litteral - found invalid value litteral"]
}
}
}
ad_proc -public sql_exact {str exact} {
# ns_log Notice "sql_exact: $str '$exact'"
if {$exact == [lindex $str 0]} { return [list $exact [lrange $str 1 end] ""] }
return [list "" $str "Not an exact($exact)"]
}
ad_proc -public sql_name {str} {
# ns_log Notice "sql_name: $str"
set keyword [sql_keyword $str]
if {"" != [lindex $keyword 0]} {
# Found a keywork - so this is NOT a name...
return [list "" $str "Not a name - is a keyword"]
}
set name [lindex $str 0]
if {[regexp {^[[:alnum:]_\.]+$} $name match]} { return [list $name [lrange $str 1 end] ""] }
return [list "" $str "Not a name - contains non-name characters"]
}
ad_proc -public sql_integer {str} {
# ns_log Notice "sql_integer: $str"
set int [lindex $str 0]
if {[regexp {^[0-9]+$} $int match]} { return [list $int [lrange $str 1 end] ""] }
return [list "" $str "Not an integer - contains non-integer characters"]
}
ad_proc -public sql_keyword {str} {
# ns_log Notice "sql_keyword: $str"
set s0 [lindex $str 0]
set keywords {all and any asc ascending avg between by collate containing desc descending distinct escape exists from full group having in is inner insert into join left like not null or order outer right set singular some starting table union update values where with}
set found_keyword ""
foreach keyword $keywords {
if {$s0 == $keyword} { return [list $keyword [lrange $str 1 end] ""] }
}
return [list "" $str "Not a keyword"]
}
# operator= '=' | '<' | '>' | '<=' | '>=' | '<>'.
ad_proc -public sql_operator {str} {
# ns_log Notice "sql_operator: $str"
set s0 [lindex $str 0]
set operators {"=" " != " "<" ">" "<=" ">=" "<>"}
set found_operator ""
foreach operator $operators {
if {$s0 == $operator} { return [list $operator [lrange $str 1 end] ""] }
}
return [list "" $str "Not a operator"]
}
# ----------------------------------------------------------------------
# SQL Parser Test Cases
# ----------------------------------------------------------------------
ad_proc -public sql_assert {
type str
} {
Checks that the string str is of sql type "type".
} {
set cmd [list $type $str]
set result [eval $cmd]
if {"" == [lindex $result 0] || "" != [lindex $result 1] || "" != [lindex $result 2]} {
ns_log Error "sql_assert: $str is $type: failed with message: '[lindex $result 2]' and unparsed: '[lindex $result 1]'"
} else {
ns_log Notice "sql_assert: $str is $type: OK"
}
lappend result $type
lappend result $str
return $result
}
ad_proc -public sql_non_assert {
type str
} {
Checks that the string str is NOT of sql type "type".
} {
set cmd [list $type $str]
set result [eval $cmd]
if {"" == [lindex $result 0] || "" != [lindex $result 1] || "" != [lindex $result 2]} {
return [list "" $str ""]
} else {
return [list "" $str "sql_assert: $str is $type: mistakenly passed"]
}
return $result
}
ad_proc -public sql_test {
} {
Executes a number of checks
} {
set e [list]
# keyword
lappend e [sql_assert sql_keyword "and"]
lappend e [sql_assert sql_keyword "where"]
lappend e [sql_assert sql_keyword "between"]
# integer
lappend e [sql_assert sql_integer "1234"]
lappend e [sql_non_assert sql_integer "1234x"]
# name
lappend e [sql_assert sql_name "asf"]
lappend e [sql_assert sql_name "a6sf2"]
lappend e [sql_non_assert sql_name "as&f"]
lappend e [sql_non_assert sql_name "from"]
# from_table_reference
lappend e [sql_assert sql_from_table_reference "func ( a , b ) alias"]
# search_value
lappend e [sql_assert sql_search_value "project_id = 46896"]
# lappend e [sql_assert sql_search_value "project_id = 46896+1"] # ToDo
lappend e [sql_assert sql_search_value "var between 1 and 10"]
lappend e [sql_assert sql_search_value "var is not null"]
lappend e [sql_assert sql_search_value "var != 30"]
lappend e [sql_assert sql_search_value "var < 10"]
lappend e [sql_assert sql_search_value "( var > 20 )"]
lappend e [sql_assert sql_search_value "not ( var != 30 )"]
lappend e [sql_assert sql_search_value "var like '%asdf%'"]
lappend e [sql_assert sql_search_value "exists ( select * from users )"]
# search_condition
lappend e [sql_assert sql_search_condition "p.project_id = 46896"]
lappend e [sql_assert sql_search_condition "p.project_id = 46896 and u.user_id = p.user_id"]
# select
lappend e [sql_assert sql_select "select * from test1"]
lappend e [sql_assert sql_select "select * from test1 , test2"]
lappend e [sql_assert sql_select "select * from test1 , test2 where 1 = 2"]
lappend e [sql_assert sql_select "select * from users where user_id in ( 1 , 2 , 3 )"]
lappend e [sql_assert sql_select "select p.project_id from im_projects p , im_projects main_p where main_p.project_id = 43373 and p.tree_sortkey between main_p.tree_sortkey and tree_right ( main_p.tree_sortkey )"]
# -------------------------
set cnt 0
set errors [list]
foreach entry $e {
set test_result [lindex $entry 0]
set test_unparsed_str [lindex $entry 1]
set test_errmsg [lindex $entry 2]
set test_type [lindex $entry 3]
set test_str [lindex $entry 4]
incr cnt
if {"" != [lindex $entry 2]} {
return [list $test_type $test_str $test_errmsg $test_unparsed_str]
lappend errors $entry
}
}
lappend errors [list "" "" "$cnt tests executed"]
return $errors
}
set bnf {
select_expression = select.
select_one_column = select.
select_column_list = select.
select = SELECT [ DISTINCT | ALL ] ( '*' | functions | value_litteral { ',' value_litteral } )
FROM from_table_reference { ',' from_table_reference }
[ WHERE search_condition ]
[ GROUP BY column_name
[ COLLATE collation_name ] { ',' column_name [ COLLATE collation_name ] } ]
[ HAVING search_condition ]
[ UNION select_expression [ ALL ] ]
[ ORDER BY order_list ].
search_condition = search_value { ( OR | AND ) search_condition }.
search_value =
value_litteral ( [ NOT ] ( between | like | in | compare | containing | starting ) |
IS [ NOT ] NULL ) |
( ALL | SOME | ANY ) '(' select_column_list ')' |
EXISTS '(' select_expression ')' |
SINGULAR '(' select_expression ')' |
'(' search_condition ')' |
NOT search_condition.
between = BETWEEN value_litteral AND value_litteral.
like = LIKE value_litteral [ ESCAPE value_litteral ].
in = IN '(' value_litteral { ',' value_litteral } | select_column_list ')'.
compare = operator ( value_litteral | '(' select_one_column ')' ).
containing = CONTAINING value_litteral.
starting = STARTING [ WITH ] value_litteral.
from_table_reference = NAME procedure_end | joined_table.
procedure_end = [ '(' value_litteral { ',' value_litteral } ')' ] [ alias_name ].
joined_table = ( name_view_procedure join_on | '(' joined_table ')' ) { join_on }.
join_on = join_type ( joined_table | name_view_procedure ) ON search_condition.
join_type = ( [ INNER | { LEFT | RIGHT | FULL } [OUTER] ] ) JOIN.
order_list = ( column_name | integer_litteral ) [ COLLATE collation_name ] [ ascending_or_descending ] { ',' order_list }.
ascending_or_descending = ASC | ASCENDING | DESC | DESCENDING.
functions = average | count | max | min | sum | upper.
average = AVG '(' [ ALL | DISTINCT ] value_litteral ')'.
count = COUNT '(' '*' | [ ALL | DISTINCT ] value_litteral ')'.
max = MAX '(' [ ALL | DISTINCT ] value_litteral ')'.
min = MIN '(' [ ALL | DISTINCT ] value_litteral ')'.
sum = SUM '(' [ ALL | DISTINCT ] value_litteral ')'.
upper = UPPER '(' value_litteral ')'.
value_litteral = VALUE_LITTERAL | NAME.
integer_litteral = INTEGER.
table_or_view_name = NAME.
name_view_procedure = NAME.
column_name = NAME.
collation_name = NAME.
alias_name = NAME.
operator = ' = ' | '<' | '>' | '< = ' | '> = ' | '<>'.
sql = insert | select | update.
insert = INSERT INTO table_or_view_name [ '(' column_name { ',' column_name } ')' ] ( VALUES '(' value_litteral { ',' value_litteral } ')' | select_expression ).
update = UPDATE table_or_view_name SET column_name ' = ' value_litteral { ',' column_name ' = ' value_litteral } [ WHERE search_condition ].
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-util-procs.tcl 0000664 0000000 0000000 00000054326 13175625757 0023220 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-util-procs.tcl
#
# Copyright (C) 2009 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Library
Utility functions
@author frank.bergmann@project-open.com
}
# --------------------------------------------------------
# Auxillary functions
# --------------------------------------------------------
ad_proc -public im_rest_doc_return {args} {
This is a replacement for doc_return that values if the
gzip_p URL parameters has been set.
} {
# Perform some magic work
db_release_unused_handles
ad_http_cache_control
# find out if we should compress or not
set query_set [ns_conn form]
set gzip_p [ns_set get $query_set gzip_p]
ns_log Notice "im_rest_doc_return: gzip_p=$gzip_p"
# Return the data
if {"1" == $gzip_p} {
return [eval "ns_returnz $args"]
} else {
return [eval "ns_return $args"]
}
}
ad_proc -public im_rest_get_rest_columns {
query_hash_pairs
} {
Reads the "columns" URL variable and returns the
list of selected REST columns or an empty list
if the variable was not specified.
} {
set rest_columns [list]
set rest_column_arg ""
array set query_hash $query_hash_pairs
if {[info exists query_hash(columns)]} { set rest_column_arg $query_hash(columns) }
if {"" != $rest_column_arg} {
# Accept both space (" ") and komma (",") separated columns
set rest_columns [split $rest_column_arg " "]
if {[llength $rest_columns] <= 1} {
set rest_columns [split $rest_column_arg ","]
}
}
return $rest_columns
}
ad_proc -private im_rest_header_extra_stuff {
{-debug 1}
} {
Returns a number of HTML header code in order to make the
REST interface create reasonable HTML pages.
} {
set extra_stuff "
"
}
ad_proc -private im_rest_debug_headers {
{-debug 1}
} {
Show REST call headers
} {
set debug "\n"
append debug "method: [ns_conn method]\n"
set header_vars [ns_conn headers]
foreach var [ad_ns_set_keys $header_vars] {
set value [ns_set get $header_vars $var]
append debug "header: $var=$value\n"
}
set form_vars [ns_conn form]
foreach var [ad_ns_set_keys $form_vars] {
set value [ns_set get $form_vars $var]
append debug "form: $var=$value\n"
}
append debug "content: [ns_conn content]\n"
ns_log Notice "im_rest_debug_headers: $debug"
return $debug
}
ad_proc -private im_rest_system_url { } {
Returns a the system's "official" URL without trailing slash
suitable to prefix all hrefs used for the JSON format.
} {
return [util_current_location]
}
# ----------------------------------------------------------------------
# Extract all fields from an object type's tables
# ----------------------------------------------------------------------
ad_proc -public im_rest_object_type_pagination_sql {
-query_hash_pairs:required
} {
Appends pagination information to a SQL statement depending on
URL parameters: "LIMIT $limit OFFSET $start".
} {
set pagination_sql ""
array set query_hash $query_hash_pairs
if {[info exists query_hash(limit)]} {
set limit $query_hash(limit)
im_security_alert_check_integer -location "im_rest_get_object_type" -value $limit
append pagination_sql "LIMIT $limit\n"
}
if {[info exists query_hash(start)]} {
set start $query_hash(start)
im_security_alert_check_integer -location "im_rest_get_object_type" -value $start
append pagination_sql "OFFSET $start\n"
}
return $pagination_sql
}
ad_proc -public im_rest_object_type_order_sql {
-query_hash_pairs:required
} {
returns an "ORDER BY" statement for the *_get_object_type SQL.
URL parameter example: sort=[{"property":"creation_date", "direction":"DESC"}]
} {
set order_sql ""
array set query_hash $query_hash_pairs
set order_by_clauses {}
if {[info exists query_hash(sort)]} {
set sort_json $query_hash(sort)
array set parsed_json [util::json::parse $sort_json]
set json_list $parsed_json(_array_)
foreach sorter $json_list {
# Skpe the leading "_object_" key
set sorter_list [lindex $sorter 1]
array set sorter_hash $sorter_list
set property $sorter_hash(property)
set direction [string toupper $sorter_hash(direction)]
# Perform security checks on the sorters
if {![regexp {} $property match]} {
ns_log Error "im_rest_object_type_order_sql: Found invalid sort property='$property'"
continue
}
if {[lsearch {DESC ASC} $direction] < 0} {
ns_log Error "im_rest_object_type_order_sql: Found invalid sort direction='$direction'"
continue
}
lappend order_by_clauses "$property $direction"
}
}
if {"" != $order_by_clauses} {
return "order by [join $order_by_clauses ", "]\n"
} else {
# No order by clause specified
return ""
}
}
# ---------------------------------------------------------------
# Get meta-informatoin information about columns
#
# The deref_plpgsql_function is able to transform an attribute
# reference (i.e. an object_id or a category_id) into the name
# of the object.
# ---------------------------------------------------------------
ad_proc -public im_rest_hard_coded_deref_plpgsql_functions {
-rest_otype:required
} {
Returns a key-value list of hard coded attribues per object type.
These values are only necessary in order to work around missing
dynfield metadata information for certain object types
} {
set list {
"acs_objects-creation_user" im_name_from_id
"im_projects-parent_id" im_name_from_id
"im_projects-company_id" im_name_from_id
"im_projects-project_type_id" im_category_from_id
"im_projects-project_status_id" im_category_from_id
"im_projects-billing_type_id" im_category_from_id
"im_projects-on_track_status_id" im_category_from_id
"im_projects-project_lead_id" im_name_from_id
"im_projects-supervisor_id" im_name_from_id
"im_projects-company_contact_id" im_name_from_id
"im_projects-project_cost_center_id" im_name_from_id
"im_conf_items-conf_item_parent_id" im_name_from_id
"im_conf_items-conf_item_cost_center_id" im_name_from_id
"im_conf_items-conf_item_owner_id" im_name_from_id
"im_conf_items-conf_item_type_id" im_name_from_id
"im_conf_items-conf_item_status_id" im_name_from_id
}
return $list
}
ad_proc -public im_rest_deref_plpgsql_functions {
-rest_otype:required
} {
Returns a key-value list of dereference functions per table-column.
} {
set dynfield_sql "
select *
from acs_attributes aa,
im_dynfield_attributes da,
im_dynfield_widgets dw
where aa.attribute_id = da.acs_attribute_id and
da.widget_name = dw.widget_name and
aa.object_type = :rest_otype
"
# Get a list of hard-coded attributes
array set dynfield_hash [im_rest_hard_coded_deref_plpgsql_functions -rest_otype $rest_otype]
# Overwrite/add with list of meta information from DynFields
db_foreach dynfields $dynfield_sql {
set key "$table_name-$attribute_name"
set dynfield_hash($key) $deref_plpgsql_function
}
return [array get dynfield_hash]
}
ad_proc -public im_rest_object_type_select_sql {
{-deref_p 0}
{-no_where_clause_p 0}
-rest_otype:required
} {
Calculates the SQL statement to extract the value for an object
of the given rest_otype. The SQL will contains a ":rest_oid"
colon-variables, so the variable "rest_oid" must be defined in
the context where this statement is to be executed.
} {
# get the list of super-types for rest_otype, including rest_otype
# and remove "acs_object" from the list
set super_types [im_object_super_types -object_type $rest_otype]
set s [list]
foreach t $super_types {
if {$t eq "acs_object"} { continue }
lappend s $t
}
set super_types $s
# Get a list of dereferencing functions
if {$deref_p} {
array set dynfield_hash [im_rest_deref_plpgsql_functions -rest_otype $rest_otype]
}
# ---------------------------------------------------------------
# Construct a SQL that pulls out all information about one object
# Start with the core object tables, so that all important fields
# are available in the query, even if there are duplicates.
#
set letters {a b c d e f g h i j k l m n o p q r s t u v w x y z}
set from {}
set froms {}
set selects { "1 as one" }
set selected_columns {}
set selected_tables {}
set tables_sql "
select table_name,
id_column
from (
select table_name,
id_column,
1 as sort_order
from acs_object_types
where object_type in ('[join $super_types "', '"]')
UNION
select table_name,
id_column,
2 as sort_order
from acs_object_type_tables
where object_type in ('[join $super_types "', '"]')
) t
order by t.sort_order
"
set table_list [db_list_of_lists tables $tables_sql]
set cnt 0
foreach table_tuple $table_list {
set table_name [lindex $table_tuple 0]
set id_column [lindex $table_tuple 1]
# Make sure not to include a table twice! There are duplicates in the query.
if {[lsearch $selected_tables $table_name] >= 0} { continue }
# Define an abbreviation for each table
set letter [lindex $letters $cnt]
lappend froms "LEFT OUTER JOIN $table_name $letter ON (o.object_id = $letter.$id_column)"
# Iterate through table columns
set columns_sql "
select lower(column_name) as column_name
from user_tab_columns
where lower(table_name) = lower(:table_name)
"
db_foreach columns $columns_sql {
if {[lsearch $selected_columns $column_name] >= 0} {
ns_log Notice "im_rest_object_type_select_sql: found ambiguous field: $table_name.$column_name"
continue
}
lappend selects "$letter.$column_name"
lappend selected_columns $column_name
# Check for dereferencing function
set key [string tolower "$table_name-$column_name"]
if {[info exists dynfield_hash($key)]} {
set deref_function $dynfield_hash($key)
lappend selects "${deref_function}($letter.$column_name) as ${column_name}_deref"
lappend selected_columns ${column_name}_deref
}
}
lappend selected_tables $table_name
incr cnt
}
set acs_object_deref_sql "im_name_from_user_id(o.creation_user) as creation_user_deref,"
if {!$deref_p} { set acs_object_deref_sql "" }
set sql "
select o.*,
o.object_id as rest_oid,
$acs_object_deref_sql
acs_object__name(o.object_id) as object_name,
[join $selects ",\n\t\t"]
from acs_objects o
[join $froms "\n\t\t"]
"
if {!$no_where_clause_p} { append sql "
where o.object_id = :rest_oid
"}
return $sql
}
ad_proc -public im_rest_object_type_columns {
{-deref_p 0}
{-include_acs_objects_p 1}
-rest_otype:required
} {
Returns a list of all columns for a given object type.
} {
set super_types [im_object_super_types -object_type $rest_otype]
if {!$include_acs_objects_p} {
# Exclude base tables if not necessary
set super_types [lsearch -inline -all -not -exact $super_types acs_object]
set super_types [lsearch -inline -all -not -exact $super_types im_biz_object]
}
# Get a list of dereferencing functions
if {$deref_p} {
array set dynfield_hash [im_rest_deref_plpgsql_functions -rest_otype $rest_otype]
}
# ---------------------------------------------------------------
# Construct a SQL that pulls out all tables for an object type,
# plus all table columns via user_tab_colums.
set columns_sql "
select distinct
lower(utc.column_name) as column_name,
lower(utc.table_name) as table_name
from
user_tab_columns utc
where
(-- check the main tables for all object types
lower(utc.table_name) in (
select lower(table_name)
from acs_object_types
where object_type in ('[join $super_types "', '"]')
) OR
-- check the extension tables for all object types
lower(utc.table_name) in (
select lower(table_name)
from acs_object_type_tables
where object_type in ('[join $super_types "', '"]')
)) and
-- avoid returning 'format' because format=json is part of every query
lower(utc.column_name) not in ('format', 'rule_engine_old_value')
"
set columns [list]
db_foreach columns $columns_sql {
lappend columns $column_name
set key "$table_name-$column_name"
if {[info exists dynfield_hash($key)]} {
lappend columns ${column_name}_deref
}
}
return $columns
}
ad_proc -public im_rest_object_type_index_columns {
-rest_otype:required
} {
Returns a list of all "index columns" for a given object type.
The index columns are the primary key columns of the object
types's tables. They will all contains the same object_id of
the object.
} {
# ---------------------------------------------------------------
# Construct a SQL that pulls out all tables for an object type,
# plus all table columns via user_tab_colums.
set index_columns_sql "
select id_column
from acs_object_type_tables
where object_type = :rest_otype
UNION
select id_column
from acs_object_types
where object_type = :rest_otype
UNION
select 'rest_oid'
"
return [db_list index_columns $index_columns_sql]
}
ad_proc -public im_rest_object_type_subtypes {
-rest_otype:required
} {
Returns a list of all object types equal or below
rest_otype (including rest_otype).
} {
set breach_p [im_security_alert_check_alphanum -location "im_rest_object_type_subtypes" -value $rest_otype]
# Return a save value to calling procedure
if {$breach_p} { return $rest_otype }
set sub_type_sql "
select sub.object_type
from acs_object_types ot,
acs_object_types sub
where ot.object_type = '$rest_otype' and
sub.tree_sortkey between ot.tree_sortkey and tree_right(ot.tree_sortkey)
order by sub.tree_sortkey
"
return [util_memoize [list db_list sub_types $sub_type_sql] 3600000]
}
# ----------------------------------------------------------------------
# Update all tables of an object type.
# ----------------------------------------------------------------------
ad_proc -public im_rest_object_type_update_sql {
{ -format "json" }
-rest_otype:required
-rest_oid:required
-hash_array:required
} {
Updates all the object's tables with the information from the
hash array.
} {
ns_log Notice "im_rest_object_type_update_sql: format=$format, rest_otype=$rest_otype, rest_oid=$rest_oid, hash_array=$hash_array"
# Stuff the list of variables into a hash
array set hash $hash_array
# ---------------------------------------------------------------
# Get all relevant tables for the object type
set tables_sql "
select table_name,
id_column
from acs_object_types
where object_type = :rest_otype
UNION
select table_name,
id_column
from acs_object_type_tables
where object_type = :rest_otype
"
db_foreach tables $tables_sql {
set index_column($table_name) $id_column
set index_column($id_column) $id_column
}
set columns_sql "
select lower(utc.column_name) as column_name,
lower(utc.table_name) as table_name
from
user_tab_columns utc,
($tables_sql) tables
where
lower(utc.table_name) = lower(tables.table_name)
order by
lower(utc.table_name),
lower(utc.column_name)
"
array unset sql_hash
db_foreach cols $columns_sql {
# Skip variables that are not available in the var hash
if {![info exists hash($column_name)]} { continue }
# Skip index columns
if {[info exists index_column($column_name)]} { continue }
# skip tree_sortkey stuff
if {"tree_sortkey" == $column_name} { continue }
if {"max_child_sortkey" == $column_name} { continue }
# ignore reserved variables
if {"rest_otype" == $column_name} { contiue }
if {"rest_oid" == $column_name} { contiue }
if {"hash_array" == $column_name} { contiue }
# ignore any "*_cache" variables (financial cache)
if {[regexp {_cache$} $column_name match]} { continue }
# Start putting together the SQL
set sqls [list]
if {[info exists sql_hash($table_name)]} { set sqls $sql_hash($table_name) }
lappend sqls "$column_name = :$column_name"
set sql_hash($table_name) $sqls
}
# Add the rest_oid to the hash
set hash(rest_oid) $rest_oid
ns_log Notice "im_rest_object_type_update_sql: [array get sql_hash]"
foreach table [array names sql_hash] {
ns_log Notice "im_rest_object_type_update_sql: Going to update table '$table'"
set sqls $sql_hash($table)
set update_sql "update $table set [join $sqls ", "] where $index_column($table) = :rest_oid"
if {[catch {
db_dml sql_$table $update_sql -bind [array get hash]
} err_msg]} {
return [im_rest_error -format $format -http_status 404 -message "Error updating $rest_otype: '$err_msg'"]
}
}
# Audit the action
im_audit -action after_update -object_id $rest_oid
ns_log Notice "im_rest_object_type_update_sql: returning"
return
}
# ----------------------------------------------------------------------
# Error Handling
# ----------------------------------------------------------------------
ad_proc -public im_rest_error {
{ -http_status 404 }
{ -format "json" }
{ -message "" }
} {
Returns a suitable REST error message
} {
ns_log Notice "im_rest_error: http_status=$http_status, format=$format, message=$message"
set url [im_url_with_query]
switch $http_status {
200 { set status_message "OK: Success!" }
304 { set status_message "Not Modified: There was no new data to return." }
400 { set status_message "Bad Request: The request was invalid. An accompanying error message will explain why." }
401 { set status_message "Not Authorized: Authentication credentials were missing or incorrect." }
403 { set status_message "Forbidden: The request is understood, but it has been refused. An accompanying error message will explain why." }
404 { set status_message "Not Found: The URI requested is invalid or the resource requested, for example a non-existing project." }
406 { set status_message "Not Acceptable: Returned when an invalid format is specified in the request." }
500 { set status_message "Internal Server Error: Something is broken. Please post to the &\#93;project-open&\#91; Open Discussions forum." }
502 { set status_message "Bad Gateway: project-open is probably down." }
503 { set status_message "Service Unavailable: project-open is up, but overloaded with requests. Try again later." }
default { set status_message "Unknown http_status '$http_status'." }
}
set page_title [lindex [split $status_message ":"] 0]
switch $format {
html {
doc_return 200 "text/html" "
[im_header $page_title [im_rest_header_extra_stuff]][im_navbar]
$status_message
[ns_quotehtml $message]
[im_footer]
"
}
json {
set result "{\"success\": false,\n\"message\": \"[im_quotejson $message]\"\n}"
doc_return 200 "application/json" $result
}
default {
ad_return_complaint 1 "Invalid format1: '$format'"
}
}
ad_script_abort
}
ad_proc -public im_rest_get_content {} {
There's no [ns_conn content] so this is a hack to get the content of the REST request.
@return string - the request
@author Dave Bauer
} {
# (taken from aol30/modules/tcl/form.tcl)
# Spool content into a temporary read/write file.
# ns_openexcl can fail, since tmpnam is known not to
# be thread/process safe. Hence spin till success
set fp ""
while {$fp eq ""} {
set filename "[ad_tmpnam][clock clicks -milliseconds].rpc2"
set fp [ns_openexcl $filename]
}
fconfigure $fp -translation binary
ns_conncptofp $fp
close $fp
set fp [open $filename r]
while {![eof $fp]} {
append text [read $fp]
}
close $fp
file delete $filename
# ns_unlink $filename #; deprecated
return $text
}
ad_proc -public im_rest_parse_json_content {
{ -format "" }
{ -content "" }
{ -rest_otype "" }
} {
Parse the JSON content of a POST request with
the values of the object to create or update.
@author Frank Bergmann
} {
# Parse the HTTP content
switch $format {
json {
ns_log Notice "im_rest_parse_json_content: going to parse json content=$content"
# {"id":8799,"email":"bbigboss@tigerpond.com","first_names":"Ben","last_name":"Bigboss"}
array set parsed_json [util::json::parse $content]
set json_list $parsed_json(_object_)
array set hash_array $json_list
# ToDo: Modify the JSON Parser to return NULL values as "" (TCL NULL) instead of "null"
foreach var [array names hash_array] {
set val $hash_array($var)
if {"null" == $val} { set hash_array($var) "" }
}
}
default {
return [im_rest_error -http_status 406 -message "Unknown format: '$format'. Expected: {json}"]
}
}
return [array get hash_array]
}
ad_proc -public im_rest_normalize_timestamp { date_string } {
Reformat JavaScript date/timestamp format to suit PostgreSQL 8.4/9.x
@author Frank Bergmann
} {
set str $date_string
# Cut off the GMT+0200... when using long format
# Wed Jul 23 2014 19:23:26 GMT+0200 (Romance Daylight Time)
if {[regexp {^(.*?)GMT\+} $str match val]} {
set str $val
}
return $str
}
ad_proc -public im_quotejson { str } {
Quote a JSON string. In particular this means escaping
single and double quotes, as well as new lines, tabs etc.
@author Frank Bergmann
} {
regsub -all {\\} $str {\\\\} str
regsub -all {"} $str {\"} str
regsub -all {\n} $str {\\n} str
regsub -all {\t} $str {\\t} str
return $str
}
intranet-rest-v5-0-2-4-1/tcl/intranet-rest-validator-procs.tcl 0000664 0000000 0000000 00000034726 13175625757 0024232 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/tcl/intranet-rest-validator-procs.tcl
#
# Copyright (C) 2014 ]project-open[
#
# All rights reserved. Please check
# http://www.project-open.com/license/ for details.
ad_library {
REST Web Service Validator
@author frank.bergmann@project-open.com
}
# -------------------------------------------------------
#
# -------------------------------------------------------
ad_proc -private im_rest_validate_call {
{ -rest_url "http://localhost:8000/intranet-rest" }
{ -rest_user_id 8799 }
} {
Performs a REST call and returns the results.
} {
# Get the list of projects
set expiry_date ""
set auth_token [im_generate_auto_login -user_id $rest_user_id -expiry_date $expiry_date]
append rest_url "/im_project"
set url [export_vars -base $rest_url {auth_token {user_id $rest_user_id}}]
set data "{\"project_name\": \"New Project\", \"project_nr\": \"12345\"}"
# ---------------------------------
set rqset [ns_set new rqset]
ns_set put $rqset "Accept" "*/*"
ns_set put $rqset "User-Agent" "[ns_info name]-Tcl/[ns_info version]"
ns_set put $rqset "Content-type" "application/x-www-form-urlencoded"
ns_set put $rqset "Content-length" [string length $data]
set timeout 15
set connInfo [ns_httpopen POST $url $rqset $timeout $data]
foreach {rfd wfd headers} $connInfo break
close $wfd
set length [ns_set iget $headers content-length]
if {$length eq ""} {
set length -1
}
set page ""
set err [catch {
# Read the content.
while {1} {
set buf [_ns_http_read $timeout $rfd $length]
append page $buf
if {$buf eq ""} {
break
}
if {$length > 0} {
incr length -[string length $buf]
if {$length <= 0} {
break
}
}
}
} errMsg]
ns_set free $headers
close $rfd
if {$err} {
return -code error -errorinfo $::errorInfo $errMsg
}
return $page
}
ad_proc -private im_rest_validate_list {
{ -rest_url "http://localhost:8000/intranet-rest" }
{ -rest_user_id 8799 }
} {
Checks permissions to "list" on all object types
} {
set auth_token [im_generate_auto_login -user_id $rest_user_id -expiry_date ""]
set not_in_object_type "
'acs_activity',
'acs_event',
'acs_mail_body',
'acs_mail_gc_object',
'acs_mail_link',
'acs_mail_multipart',
'acs_mail_queue_message',
'acs_message',
'acs_message_revision',
'acs_named_object',
'acs_object',
'acs_reference_repository',
'acs_sc_contract',
'acs_sc_implementation',
'acs_sc_msg_type',
'acs_sc_operation',
'admin_rel',
'ams_object_revision',
'apm_application',
'apm_package',
'apm_package_version',
'apm_parameter',
'apm_parameter_value',
'apm_service',
'application_group',
'authority',
'bt_bug',
'bt_bug_revision',
'bt_patch',
'calendar',
'cal_item',
'composition_rel',
'content_extlink',
'content_folder',
'content_item',
'content_keyword',
'content_module',
'content_revision',
'content_symlink',
'content_template',
'cr_item_child_rel',
'cr_item_rel',
'dynamic_group_type',
'etp_page_revision',
'image',
'im_biz_object',
'im_component_plugin',
'im_cost',
'im_gantt_person',
'im_gantt_project',
'im_indicator',
'im_investment',
'im_menu',
'im_note',
'im_repeating_cost',
'im_report',
'journal_article',
'journal_entry',
'journal_issue',
'news_item',
'notification',
'notification_delivery_method',
'notification_interval',
'notification_reply',
'notification_request',
'notification_type',
'person',
'party',
'postal_address',
'rel_segment',
'rel_constraint',
'site_node',
'user_blob_response_rel',
'user_portrait_rel',
'workflow',
'workflow_lite',
'workflow_case_log_entry'
"
set otypes_sql "
select
ot.object_type,
ot.pretty_name,
ot.object_type_gif,
rot.object_type_id,
im_object_permission_p(rot.object_type_id, :rest_user_id, 'read') as rest_user_read_p
from
acs_object_types ot,
im_rest_object_types rot
where
ot.object_type = rot.object_type and
ot.object_type not in ($not_in_object_type)
and ot.object_type not like '%wf'
order by
ot.object_type
"
set debug_html ""
db_foreach otypes $otypes_sql {
set operation "list"
set url [export_vars -base "$rest_url/$object_type" {auth_token {user_id $rest_user_id} {format json} }]
ns_log Notice "im_rest_validate_list: $object_type: Before im_httpget $url"
set result [im_httpget $url]
ns_log Notice "im_rest_validate_list: $object_type: After im_httpget $url"
set parsed_result [util::json::parse $result]
array unset result_hash
array set result_hash [lindex $parsed_result 1]
set total ""
set success ""
set data ""
set message ""
if {[info exists result_hash(total)]} { set total $result_hash(total) }
if {[info exists result_hash(success)]} { set success $result_hash(success) }
if {[info exists result_hash(message)]} { set message $result_hash(message) }
if {[info exists result_hash(data)]} { set data [lindex [lindex $result_hash(data) 1] 0 1] }
set data_len [llength $data]
set link "url"
set color "white"
if {$should_read_p && ($total == 0 || $data_len == 0 || $success != "true")} { set color "#FFAAFF" }
if {!$should_read_p && ($total > 0 || $data_len > 0 || $success != "false")} { set color "#FFAAAA" }
append debug_html "
$project_id
$project_name
$operation
$should_read_p
$total
$success
$message
$data_len
$link
\n"
}
set debug_header "
oid
oname
operation
access_p
total
success
message
data
url
\n"
ad_return_complaint 1 "
$debug_header $debug_html
"
}
ad_proc -private im_rest_validate_projects {
{ -rest_url "http://localhost:8000/intranet-rest" }
{ -rest_user_id 8799 }
} {
Checks permissions on ]po[ projects
} {
set auth_token [im_generate_auto_login -user_id $rest_user_id -expiry_date ""]
# Get the list of projects together with permissions for the rest_user_id
set add_projects [im_permission $rest_user_id "add_projects"]
set view_projects_all [im_permission $rest_user_id "view_projects_all"]
set view_projects_history [im_permission $rest_user_id "view_projects_history"]
set edit_projects_all [im_permission $rest_user_id "edit_projects_all"]
set edit_project_basedata [im_permission $rest_user_id "edit_project_basedata"]
set edit_project_status [im_permission $rest_user_id "edit_project_status"]
set validate_read_p 0
set validate_list_p 0
set validate_update_p 1
set validate_create_p 0
set validate_delete_p 0
# ------------------------------------------------------------------------
# Create a new Project
# ------------------------------------------------------------------------
if {$validate_create_p} {
set operation "create"
set url [export_vars -base "$rest_url/im_project" {auth_token {user_id $rest_user_id} project_id {format json} }]
ns_log Notice "im_rest_validate_projects - create: Before im_httppost $url"
set result [im_httppost $url]
ns_log Notice "im_rest_validate_projects - create: After im_httppost $url"
set parsed_result [util::json::parse $result]
array unset result_hash
array set result_hash [lindex $parsed_result 1]
set total ""
set success ""
set data ""
set message ""
if {[info exists result_hash(total)]} { set total $result_hash(total) }
if {[info exists result_hash(success)]} { set success $result_hash(success) }
if {[info exists result_hash(message)]} { set message $result_hash(message) }
if {[info exists result_hash(data)]} { set data [lindex [lindex $result_hash(data) 1] 0 1] }
set data_len [llength $data]
set link "url"
}
# ------------------------------------------------------------------------
# Check a number of projects for read/list permissions
# ------------------------------------------------------------------------
set sql "
select sub_p.project_id,
sub_p.project_name,
sub_p.project_status_id,
sub_p.project_type_id,
(select max(bom.object_role_id)
from acs_rels r, im_biz_object_members bom
where r.rel_id = bom.rel_id and
r.object_id_one = sub_p.project_id and
r.object_id_two in (
select :rest_user_id UNION
select group_id from group_distinct_member_map where member_id = :rest_user_id
)
) as member_role_id
from im_projects main_p,
im_projects sub_p
where main_p.parent_id is null and
sub_p.tree_sortkey between main_p.tree_sortkey and tree_right(main_p.tree_sortkey)
order by sub_p.tree_sortkey
LIMIT 20
"
set lol [db_list_of_lists validate_projects $sql]
set debug_html ""
foreach l $lol {
set project_id [lindex $l 0]
set project_name [lindex $l 1]
set project_status_id [lindex $l 2]
set project_type_id [lindex $l 3]
set member_role_id [lindex $l 4]
switch $member_role_id {
"" {
set should_read_p 0
set should_write_p 0
}
1300 {
# Full Member - may read
set should_read_p 1
set should_write_p 0
}
1301 {
# Project Manager - may read and write
set should_read_p 1
set should_write_p 1
}
default {
ad_return_complaint 1 "im_rest_validate_projects: Unknown role '$member_role_id'"
}
}
if {$project_type_id == [im_project_type_task]} {
# special permissions for timesheet tasks
im_timesheet_task_permissions $rest_user_id $project_id view should_read_p should_write_p admin
}
# Get the project using the multi-project call
if {$validate_list_p} {
set operation "list"
set url [export_vars -base "$rest_url/im_project" {auth_token {user_id $rest_user_id} project_id {format json} }]
ns_log Notice "im_rest_validate_projects - list: Before im_httpget $url"
set result [im_httpget $url]
ns_log Notice "im_rest_validate_projects - list: After im_httpget $url"
set parsed_result [util::json::parse $result]
array unset result_hash
array set result_hash [lindex $parsed_result 1]
set total ""
set success ""
set data ""
set message ""
if {[info exists result_hash(total)]} { set total $result_hash(total) }
if {[info exists result_hash(success)]} { set success $result_hash(success) }
if {[info exists result_hash(message)]} { set message $result_hash(message) }
if {[info exists result_hash(data)]} { set data [lindex [lindex $result_hash(data) 1] 0 1] }
set data_len [llength $data]
set link "url"
set color "white"
if {$should_read_p && ($total == 0 || $data_len == 0 || $success != "true")} { set color "#FFAAFF" }
if {!$should_read_p && ($total > 0 || $data_len > 0 || $success != "false")} { set color "#FFAAAA" }
append debug_html "
$project_id
$project_name
$operation
$should_read_p
$total
$success
$message
$data_len
$link
\n"
}
# Get the project using the multi-project call
if {$validate_read_p} {
set operation "read"
set url [export_vars -base "$rest_url/im_project/$project_id" {auth_token {user_id $rest_user_id} {format json} }]
ns_log Notice "im_rest_validate_projects: Before im_httpget $url"
set result [im_httpget $url]
ns_log Notice "im_rest_validate_projects: After im_httpget $url"
set parsed_result [util::json::parse $result]
array unset result_hash
array set result_hash [lindex $parsed_result 1]
set total ""
set success ""
set data ""
set message ""
if {[info exists result_hash(total)]} { set total $result_hash(total) }
if {[info exists result_hash(success)]} { set success $result_hash(success) }
if {[info exists result_hash(message)]} { set message $result_hash(message) }
if {[info exists result_hash(data)]} { set data [lindex [lindex $result_hash(data) 1] 0 1] }
set link "url"
set color "white"
if {$should_read_p && ($total == 0 || $data_len == 0 || $success != "true")} { set color "#FFAAFF" }
if {!$should_read_p && ($total > 0 || $data_len > 0 || $success != "false")} { set color "#FFAAAA" }
append debug_html "
$project_id
$project_name
$operation
$should_read_p
$total
$success
$message
[llength $data]
$link
\n"
}
# Get the project using the multi-project call
if {$validate_update_p} {
set operation "update"
set form_vars [export_vars {auth_token {user_id $rest_user_id} {format json}}]
set prob [expr {round(rand() * 100.0 * 10000.0) / 10000.0}]
set form [ns_set new]
ns_set put $form presales_probability $prob
set url "$rest_url/im_project/$project_id"
set url [export_vars -base "$rest_url/im_project/$project_id" {auth_token {user_id $rest_user_id} {format json} }]
ns_log Notice "im_rest_validate_projects: Before im_httppost $url"
set result [im_httppost $url "" ""]
ns_log Notice "im_rest_validate_projects: After im_httppost $url"
ad_return_complaint 1 "
$result
"
set parsed_result [util::json::parse $result]
array unset result_hash
array set result_hash [lindex $parsed_result 1]
set total ""
set success ""
set data ""
set message ""
if {[info exists result_hash(total)]} { set total $result_hash(total) }
if {[info exists result_hash(success)]} { set success $result_hash(success) }
if {[info exists result_hash(message)]} { set message $result_hash(message) }
if {[info exists result_hash(data)]} { set data [lindex [lindex $result_hash(data) 1] 0 1] }
set link "url"
set color "white"
if {$should_write_p && ($total == 0 || $data_len == 0 || $success != "true")} { set color "#FFAAFF" }
if {!$should_write_p && ($total > 0 || $data_len > 0 || $success != "false")} { set color "#FFAAAA" }
append debug_html "
intranet-rest-v5-0-2-4-1/www/auto-login.tcl 0000664 0000000 0000000 00000003025 13175625757 0020430 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/www/auto-login.tcl
#
# Copyright (C) 2009 ]project-open[
#
ad_page_contract {
Home page for REST service, when accessing from the browser.
The page shows a link to the documentation Wiki and a status
of CRUD for every object type.
@author frank.bergmann@project-open.com
} {
}
# Parameters passed aside of page_contract
# from intranet-rest-procs.tcl:
#
# [list object_type $object_type] \
# [list format $format] \
# [list user_id $user_id] \
# [list object_id $object_id] \
# [list query_hash $query_hash] \
if {![info exists user_id]} { set user_id 0 }
if {![info exists format]} { set format "html" }
set auto_login [im_generate_auto_login -user_id $user_id]
set username ""
set name ""
db_0or1row user_info "
select *,
im_name_from_user_id(user_id) as name
from cc_users
where user_id = :user_id
"
switch $format {
json {
set result "{\"success\": true,
\"message\": \"Authenticated\",
\"user_id\": $user_id,
\"user_name\": \"[im_quotejson $name]\",
\"username\": \"[im_quotejson $username]\",
\"token\": \"[im_quotejson $auto_token]\",
}"
doc_return 200 "application/json" $result
ad_script_abort
}
xml {
doc_return 200 "text/xml" "
$user_id$name$username$auto_login
"
ad_script_abort
}
default {
# just continue with the HTML stuff below,
# returning the result as text/html
}
}
intranet-rest-v5-0-2-4-1/www/data-source/ 0000775 0000000 0000000 00000000000 13175625757 0020055 5 ustar 00root root 0000000 0000000 intranet-rest-v5-0-2-4-1/www/data-source/domain-proxy.adp 0000664 0000000 0000000 00000000016 13175625757 0023166 0 ustar 00root root 0000000 0000000 @json;noquote@ intranet-rest-v5-0-2-4-1/www/data-source/domain-proxy.tcl 0000664 0000000 0000000 00000001451 13175625757 0023210 0 ustar 00root root 0000000 0000000 # /packages/sencha-rest/www/data-source/domain-proxy.tcl
#
# Copyright (C) 2015 ]project-open[
ad_page_contract {
Fetches a page from www.project-open.net
@param project_id The project
@author frank.bergmann@project-open.com
} {
{url ""}
}
# --------------------------------------------
# Security & Permissions
#
if {![regexp {^http://www\.project-open\.[a-z]+} $url match]} {
ad_return_complaint 1 "Domain-proxy: This proxy can relay information only from project-open.* domains"
ad_script_abort
}
ns_log Notice "/intranet-rest/data-source/domain-proxy.tcl: url=$url"
# --------------------------------------------
# Fetch and return the page
#
if {[catch {
set json [im_httpget $url]
} err_msg]} {
set json "{'success': false, 'message': 'Error message: $err_msg'}"
}
intranet-rest-v5-0-2-4-1/www/data-source/next-object-id.adp 0000664 0000000 0000000 00000000132 13175625757 0023353 0 ustar 00root root 0000000 0000000 {'success': true, 'message': 'success', 'data': {'object_id': <%= [im_new_object_id] %>}}
intranet-rest-v5-0-2-4-1/www/data-source/project-task-tree-action.adp 0000664 0000000 0000000 00000000051 13175625757 0025355 0 ustar 00root root 0000000 0000000 {success:@success@, message: '@message@'} intranet-rest-v5-0-2-4-1/www/data-source/project-task-tree-action.tcl 0000664 0000000 0000000 00000005157 13175625757 0025407 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/www/data-source/project-trask-tree-action.tcl
#
# Copyright (C) 2013 ]project-open[
#ad_page_contract {
# Recieves a POST request from Sencha for an update
# of in-line editing a TreeGrid
# @author frank.bergmann@project-open.com
#} {
# {debug_p 0}
#}
# ---------------------------------------------------------------
#
# ---------------------------------------------------------------
set current_user_id [auth::require_login]
set debug_p 0
ns_log Notice "project-task-tree-action: query_hash_pairs=$query_hash_pairs"
array set var_hash $query_hash_pairs
set action $var_hash(action)
# Default values for JSON return message
set success "true"
set message "Successfully performed action=$action"
if {[catch {
# Parse the JSON POST data
set post_content [ns_conn content]
array set json_hash [util::json::parse $post_content]
ns_log Notice "project-task-tree-action: json_hash=[array get json_hash]"
# ---------------------------------------------------------------
# Check for single update
# ---------------------------------------------------------------
if {[info exists json_hash(_object_)]} {
set json_list $json_hash(_object_)
ns_log Notice "project-task-tree-action: object: json_list=$json_list"
im_rest_project_task_tree_action -pass 1 -action $action -var_hash_list $json_list
im_rest_project_task_tree_action -pass 2 -action $action -var_hash_list $json_list
}
# ---------------------------------------------------------------
# Check for multiple updates
# ---------------------------------------------------------------
if {[info exists json_hash(_array_)]} {
set json_array $json_hash(_array_)
foreach pass {1 2} {
ns_log Notice "project-task-tree-action: pass=$pass, array=$json_array"
set repeat_p 1
set cnt 0
while {$repeat_p && $cnt < 100} {
set repeat_p 0
incr cnt
foreach array_elem $json_array {
ns_log Notice "project-task-tree-action: rep=$cnt, pass=$pass, array_elem=$array_elem"
set obj [lindex $array_elem 0]
set json_list [lindex $array_elem 1]
ns_log Notice "project-task-tree-action: pass=$pass, decomposing array_elem: $obj=$json_list"
set not_finished_p [im_rest_project_task_tree_action -pass $pass -action $action -var_hash_list $json_list]
if {1 eq $not_finished_p} { set repeat_p 1 }
}
}
}
}
} err_msg]} {
ns_log Error "project-task-tree-action: Reporting back error: [ad_print_stack_trace]"
set success "false"
set message [im_rest_error -format json -http_status 404 -message "Internal Error: [ad_print_stack_trace]"]
}
intranet-rest-v5-0-2-4-1/www/data-source/project-task-tree.json.adp 0000664 0000000 0000000 00000000060 13175625757 0025052 0 ustar 00root root 0000000 0000000 {'text':'.','children': [
@task_json;noquote@
}
intranet-rest-v5-0-2-4-1/www/data-source/project-task-tree.json.tcl 0000664 0000000 0000000 00000023350 13175625757 0025077 0 ustar 00root root 0000000 0000000 # /packages/sencha-rest/www/project-tree.json.tcl
#
# Copyright (C) 2013 ]project-open[
ad_page_contract {
Returns a JSON tree structure suitable for batch-loading a project TreeStore
@param project_id The project
@author frank.bergmann@project-open.com
@param node Passed by ExtJS to load sub-trees of a tree.
Normally not used, just in case of error.
} {
project_id:integer
{debug_p 0}
{node ""}
}
set main_project_id $project_id
set root_project_id $project_id
if {"" ne $node && [string is integer $node]} { set root_project_id $node }
ns_log Notice "project-task-tree.json: node=$node, main_project_id=$main_project_id, root_project_id=$root_project_id, query_hash_pairs=$query_hash_pairs"
# --------------------------------------------
# Security & Permissions
#
set current_user_id [auth::require_login]
im_project_permissions $current_user_id $main_project_id view read write admin
if {!$read} {
im_rest_error -format "json" -http_status 403 -message "You (user #$current_user_id) have no permissions to read project #$main_project_id"
ad_script_abort
}
# --------------------------------------------
# Task dependencies: Collect before the main loop
# predecessor_hash: The list of predecessors for each task
set task_dependencies_sql "
select distinct ttd.*,
coalesce(ttd.difference, 0.0) as diff
from im_projects main_p,
im_projects p,
im_timesheet_task_dependencies ttd
where p.tree_sortkey between main_p.tree_sortkey and tree_right(main_p.tree_sortkey) and
(ttd.task_id_one = p.project_id OR ttd.task_id_two = p.project_id) and
main_p.project_id = :main_project_id
"
db_foreach task_dependencies $task_dependencies_sql {
set pred [list]
if {[info exists predecessor_hash($task_id_one)]} { set pred $predecessor_hash($task_id_one) }
lappend pred "{id: $dependency_id, pred_id: $task_id_two, succ_id: $task_id_one, type_id: $dependency_type_id, diff: $diff}"
set predecessor_hash($task_id_one) $pred
}
# ad_return_complaint 1 "
[join [array get predecessor_hash] " "]
# --------------------------------------------
# Assignees: Collect all before the main loop
#
set assignee_sql "
select r.*,
bom.*,
to_char(coalesce(bom.percentage,0), '990.0') as percent_pretty,
im_name_from_user_id(r.object_id_two) as user_name,
im_email_from_user_id(r.object_id_two) as user_email,
im_initials_from_user_id(r.object_id_two) as user_initials
from im_projects main_p,
im_projects p,
acs_rels r,
im_biz_object_members bom
where r.rel_id = bom.rel_id and
r.object_id_one = p.project_id and
main_p.project_id = :main_project_id and
p.tree_sortkey between main_p.tree_sortkey and tree_right(main_p.tree_sortkey)
order by
user_initials
"
db_foreach assignee $assignee_sql {
set assignees [list]
if {[info exists assignee_hash($object_id_one)]} { set assignees $assignee_hash($object_id_one) }
lappend assignees "{id:$rel_id, user_id:$object_id_two, percent:$percent_pretty}"
set assignee_hash($object_id_one) $assignees
}
# --------------------------------------------
# Get the list of projects that should not be displayed
# Currently these are projects marked as "deleted".
# We now also want to show "normal projects" / subprojects.
#
set non_display_projects_sql "
select distinct sub_p.project_id -- Select all sup-projects of somehow non-displays
from im_projects super_p,
im_projects sub_p
where sub_p.tree_sortkey between super_p.tree_sortkey and tree_right(super_p.tree_sortkey) and
sub_p.project_id != :main_project_id and
super_p.project_id in (
-- The list of projects that should not be displayed
select p.project_id
from im_projects p,
acs_objects o,
im_projects main_p
where main_p.project_id = :main_project_id and
main_p.project_id != p.project_id and
p.project_id = o.object_id and
p.tree_sortkey between main_p.tree_sortkey and tree_right(main_p.tree_sortkey) and
p.project_status_id = [im_project_status_deleted]
)
"
# set non_display_projects [db_list non_display_projects $non_display_projects_sql]
set non_display_projects [list]
lappend non_display_projects 0
# ad_return_complaint 1 $non_display_projects
# --------------------------------------------
# Get all the variables valid for gantt task
#
set valid_vars [util_memoize [list im_rest_object_type_columns -deref_p 0 -rest_otype "im_timesheet_task"]]
set valid_vars [lsort -unique $valid_vars]
# --------------------------------------------
# Main hierarchical SQL
#
set projects_sql "
select o.*,
bo.*,
t.*,
gp.*,
p.*, -- p.* needs to come after gp.* in case gp is NULL
tree_level(p.tree_sortkey) as level,
(p.end_date - p.start_date)::interval as duration,
(select count(*) from im_projects child where child.parent_id = p.project_id) as num_children,
CASE WHEN bts.open_p = 'o' THEN 'true' ELSE 'false' END as expanded,
p.sort_order,
round(p.percent_completed * 10.0) / 10.0 as percent_completed
from im_projects main_p,
im_projects p
LEFT OUTER JOIN acs_objects o ON (p.project_id = o.object_id)
LEFT OUTER JOIN im_biz_objects bo ON (p.project_id = bo.object_id)
LEFT OUTER JOIN im_timesheet_tasks t ON (p.project_id = t.task_id)
LEFT OUTER JOIN im_gantt_projects gp ON (p.project_id = gp.project_id)
LEFT OUTER JOIN im_biz_object_tree_status bts ON (
p.project_id = bts.object_id and
bts.page_url = 'default' and
bts.user_id = :current_user_id
)
where main_p.project_id = :root_project_id and
p.tree_sortkey between main_p.tree_sortkey and tree_right(main_p.tree_sortkey) and
p.project_id not in ([join $non_display_projects ","])
order by
coalesce(p.sort_order, 0)
"
# Read the query into a Multirow, so that we can order
# it according to sort_order within the individual sub-levels.
db_multirow task_multirow task_list $projects_sql {
# By default keep the main project "open".
if {"" == $parent_id} { set expanded "true" }
# Deal with partial data if exactly one of the two start or end dates are set
if {"" == $start_date && "" != $end_date} { set start_date $end_date }
if {"" != $start_date && "" == $end_date} { set end_date $start_date }
# Workaround for bug in Sencha tree display if cost_center_id is empty
if {"" == $cost_center_id} { set cost_center_id [im_cost_center_company] }
}
# Sort the tree according to the specified sort order
# "sort_order" is an integer, so we have to tell the sort algorithm to use integer sorting
ns_log Notice "project-tree.json.tcl: starting to sort multirow"
multirow_sort_tree -integer task_multirow project_id parent_id sort_order
set task_json ""
set ctr 0
set old_level 1
set indent ""
template::multirow foreach task_multirow {
ns_log Notice "project-tree.json.tcl: project_id=$project_id, task_id=$task_id"
if {$debug_p} { append task_json "\n// finish: ctr=$ctr, level=$level, old_level=$old_level\n" }
# -----------------------------------------
# Close off the previous entry
# -----------------------------------------
# This is the first child of the previous item
# Increasing the level always happens in steps of 1
if {$level > $old_level} {
append task_json ",\n${indent}\tchildren:\[\n"
}
# A group of children needs to be closed.
# Please note that this can cascade down to several levels.
while {$level < $old_level} {
append task_json "\n${indent}\}\]\n"
incr old_level -1
set indent ""
for {set i 0} {$i < $old_level} {incr i} { append indent "\t" }
}
# The current task is on the same level as the previous.
# This is also executed after reducing the old_level in the previous while loop
if {$level == $old_level} {
if {0 != $ctr} {
append task_json "${indent}\n${indent}\},\n"
}
}
if {$debug_p} { append task_json "\n// $project_name: ctr=$ctr, level=$level, old_level=$old_level\n" }
set indent ""
for {set i 0} {$i < $level} {incr i} { append indent "\t" }
if {0 == $num_children} { set leaf_json "true" } else { set leaf_json "false" }
set predecessor_tasks [list]
set assignees [list]
if {[info exists predecessor_hash($project_id)]} { set predecessor_tasks $predecessor_hash($project_id) }
if {[info exists assignee_hash($project_id)]} { set assignees $assignee_hash($project_id) }
set quoted_char_map {"\n" "\\n" "\r" "\\r" "\"" "\\\"" "\\" "\\\\"}
set quoted_project_name [string map $quoted_char_map $project_name]
set type ""
switch $project_type_id {
100 { set type "task" }
101 { set type "ticket" }
102 - 103 { set type "crm" }
2502 { set type "sla" }
2504 { set type "milestone" }
2510 { set type "program" }
4597 { set type "release-item" }
4599 { set type "release" }
}
if {[im_category_is_a $project_type_id [im_project_type_gantt]]} { set type "project" }
if {"t" eq $milestone_p} { set type "milestone" }
# ToDo: Deal with empty type
append task_json "${indent}\{
${indent}\tid:$project_id,
${indent}\ttext:\"$quoted_project_name\",
${indent}\ticonCls:\"icon-$type\",
${indent}\tpredecessors:\[[join $predecessor_tasks ", "]\],
${indent}\tassignees:\[[join $assignees ", "]\],
${indent}\texpanded:$expanded,
"
foreach var $valid_vars {
# Skip xml_* variables (only used by MS-Project)
if {[regexp {^xml_} $var match]} { continue }
# Append the value to the JSON output
set value [set $var]
set quoted_value [string map $quoted_char_map $value]
append task_json "${indent}\t$var:\"$quoted_value\",\n"
}
append task_json "${indent}\tleaf:$leaf_json"
incr ctr
set old_level $level
}
set level 0
while {$level < $old_level} {
# A group of children needs to be closed.
# Please note that this can cascade down to several levels.
append task_json "\n${indent}\}\]\n"
incr old_level -1
set indent ""
for {set i 0} {$i < $old_level} {incr i} { append indent "\t" }
}
intranet-rest-v5-0-2-4-1/www/data-source/success.adp 0000664 0000000 0000000 00000000050 13175625757 0022206 0 ustar 00root root 0000000 0000000 {'success': true, 'message': 'success'}
intranet-rest-v5-0-2-4-1/www/dynfield-widget-values.adp 0000664 0000000 0000000 00000000304 13175625757 0022705 0 ustar 00root root 0000000 0000000 @xml;noquote@@page_title;literal@@context_bar;literal@
@html;noquote@
intranet-rest-v5-0-2-4-1/www/dynfield-widget-values.tcl 0000664 0000000 0000000 00000005724 13175625757 0022736 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/www/dynfield-widget-values.tcl
#
# Copyright (C) 2010 ]project-open[
#
# ---------------------------------------------------------
# Parameters passed aside of page_contract
# from intranet-rest-procs.tcl:
#
# [list object_type $object_type] \
# [list format $format] \
# [list user_id $user_id] \
# [list object_id $object_id] \
# [list query_hash_pairs $query_hash_pairs] \
if {![info exists user_id]} { set user_id 0 }
if {![info exists format]} { set format "html" }
set rest_url "[im_rest_system_url]/intranet-rest"
array set query_hash $query_hash_pairs
if {![info exists query_hash(widget_id)]} {
switch $format {
html {
ad_return_complaint 1 "Please specify 'widget_id'."
ad_script_abort
}
xml {
im_rest_error -http_status 406 -message "Parameter 'widget_id' missing, please specify"
return
}
}
}
if {0 == $user_id} {
# User not autenticated
switch $format {
html {
ad_return_complaint 1 "Not authorized"
ad_script_abort
}
xml {
im_rest_error -http_status 401 -message "Not authenticated"
return
}
}
}
set widget_id $query_hash(widget_id)
set widget_values {}
db_0or1row widget_info "
select *,
widget as tcl_widget
from im_dynfield_widgets
where widget_id = :widget_id
"
if {![info exists widget_name]} {
switch $format {
html {
ad_return_complaint 1 "Invalid 'widget_id'"
ad_script_abort
}
xml {
im_rest_error -http_status 406 -message "Invalid 'widget_id'"
return
}
}
}
# Extract the values
switch $tcl_widget {
generic_sql {
# parameters contains {custom {sql {...}}}
set custom [lindex $parameters 0]
set sql_list [lindex $custom 1]
set sql [lindex $sql_list 1]
# ad_return_complaint 1 "$sql"
set widget_values [db_list_of_lists widget_sql $sql]
set widget_values [ns_quotehtml $widget_values]
}
default {
set message "Widget type '$tcl_widget' not implemented yet"
switch $format {
html {
ad_return_complaint 1 $message
ad_script_abort
}
xml {
im_rest_error -http_status 406 -message $message
return
}
}
}
}
# Got a user already authenticated by Basic HTTP auth or auto-login
switch $format {
xml {
# ---------------------------------------------------------
# Return the list of widget values
# ---------------------------------------------------------
set xml_p 1
set xml ""
foreach pair $widget_values {
append xml "[lindex $pair 1]\n"
}
set xml "\n\n$xml\n"
}
default {
set xml_p 0
set page_title [lang::message::lookup "" intranet-rest.Dynfield_Widget_Values "Dynfield Widget Values"]
set context_bar ""
set dynfield_widget_values "widget_id=$widget_id"
set html ""
foreach pair $widget_values {
append html "
[lindex $pair 0]
[lindex $pair 1]
\n"
}
set html "
\n$html
\n"
# End of HTML stuff
}
}
intranet-rest-v5-0-2-4-1/www/index.adp 0000664 0000000 0000000 00000000625 13175625757 0017446 0 ustar 00root root 0000000 0000000 @json;noquote@@page_title;literal@@context_bar;literal@
intranet-rest-v5-0-2-4-1/www/index.tcl 0000664 0000000 0000000 00000027037 13175625757 0017472 0 ustar 00root root 0000000 0000000 # /packages/intranet-rest/www/index.tcl
#
# Copyright (C) 2009 ]project-open[
#
# ---------------------------------------------------------
# Parameters passed aside of page_contract
# from intranet-rest-procs.tcl:
#
# [list object_type $object_type] \
# [list format $format] \
# [list rest_user_id $rest_user_id] \
# [list object_id $object_id] \
# [list query_hash_pairs_ $query_hash_pairs] \
if {![info exists rest_user_id]} { set rest_user_id 0 }
if {![info exists format]} { set format "html" }
set rest_url "[im_rest_system_url]/intranet-rest"
if {0 == $rest_user_id} {
# User not autenticated
switch $format {
html {
ad_return_complaint 1 "Not authorized"
ad_script_abort
}
default {
im_rest_error -format $format -http_status 401 -message "Not authenticated"
ad_script_abort
}
}
}
# Got a user already authenticated by Basic HTTP auth or auto-login
set not_in_object_type "
'acs_activity',
'acs_event',
'acs_mail_body',
'acs_mail_gc_object',
'acs_mail_link',
'acs_mail_multipart',
'acs_mail_queue_message',
'acs_message',
'acs_message_revision',
'acs_named_object',
'acs_object',
'acs_reference_repository',
'acs_sc_contract',
'acs_sc_implementation',
'acs_sc_msg_type',
'acs_sc_operation',
'admin_rel',
'ams_object_revision',
'apm_application',
'apm_package',
'apm_package_version',
'apm_parameter',
'apm_parameter_value',
'apm_service',
'application_group',
'authority',
'bt_bug',
'bt_bug_revision',
'bt_patch',
'calendar',
'cal_item',
'composition_rel',
'content_extlink',
'content_folder',
'content_item',
'content_keyword',
'content_module',
'content_revision',
'content_symlink',
'content_template',
'cr_item_child_rel',
'cr_item_rel',
'dynamic_group_type',
'etp_page_revision',
'image',
'im_biz_object',
'im_component_plugin',
'im_cost',
'im_gantt_person',
'im_gantt_project',
'im_indicator',
'im_investment',
'im_menu',
'im_note',
'im_repeating_cost',
'im_report',
'journal_article',
'journal_entry',
'journal_issue',
'meta_category_rel',
'news_item',
'notification',
'notification_delivery_method',
'notification_interval',
'notification_reply',
'notification_request',
'notification_type',
'person',
'party',
'postal_address',
'rel_segment',
'rel_constraint',
'site_node',
'user_blob_response_rel',
'user_meta_category_rel',
'user_portrait_rel',
'workflow',
'workflow_lite',
'workflow_case_log_entry'
"
switch $format {
json {
# ---------------------------------------------------------
# Return the list of object types
# ---------------------------------------------------------
set json_p 1
set otype_sql "
select *
from acs_object_types aot
where aot.object_type not in ($not_in_object_type)
order by object_type
"
set otype_json ""
set otype_cnt 0
db_foreach otypes $otype_sql {
incr otype_cnt
lappend otype_json "{\"object_type\": \"$object_type\",\
\"supertype\": \"$supertype\",\
\"pretty_name\": \"$pretty_name\",\
\"table_name\": \"$table_name\",\
\"id_column\": \"$id_column\",\
\"name_method\": \"$name_method\",\
\"type_extension_table\": \"$type_extension_table\",\
\"status_column\": \"$status_column\",\
\"type_column\": \"$type_column\",\
\"status_type_table\": \"$status_type_table\",\
\"type_category_type\": \"$type_category_type\",\
\"status_category_type\": \"$status_category_type\"}"
}
set json "{\"success\": true, \"total\": $otype_cnt, \"message\": \"im_rest_get_object_type: Data loaded\", \"data\": \[\n[join $otype_json ",\n"]\n\]}"
}
default {
# ---------------------------------------------------------
# Continue as a normal HTML page
# ---------------------------------------------------------
set json_p 0
set current_user_id [auth::require_login]
set current_user_is_admin_p [im_is_user_site_wide_or_intranet_admin $current_user_id]
set page_title [lang::message::lookup "" intranet-rest.REST_API "REST API"]
set context_bar [im_context_bar $page_title]
set toggle_url "/intranet/admin/toggle"
set return_url [im_url_with_query]
# ---------------------------------------------------------
# Make sure we've got a REST object_type object for every
# acs_object_types.object_type
# ---------------------------------------------------------
set missing_object_types [db_list missing_object_types "
select object_type
from acs_object_types
where object_type not in (
select object_type
from im_rest_object_types
)
"]
foreach object_type $missing_object_types {
db_string insert_rest_object_type "
select im_rest_object_type__new(
null,
'im_rest_object_type',
now(),
:current_user_id,
'[ad_conn peeraddr]',
null,
:object_type,
null,
null
)
"
}
# ---------------------------------------------------------
# What operations are currently implemented on the REST API?
# ---------------------------------------------------------
array set crud_hash {
im_invoice "CRUL"
im_invoice_item "CRUL"
im_timesheet_task_dependency "CRUL"
im_project "CRUL"
im_trans_task "CRUL"
}
array set wiki_hash {
object_type_im_indicator 1
object_type_acs_attribute 1
object_type_acs_object 1
object_type_acs_object_type 1
object_type_acs_permission 1
object_type_acs_privilege 1
object_type_acs_rel 1
object_type_apm_package 1
object_type_cal_item 1
object_type_calendar 1
object_type_group 1
object_type_im_biz_object 1
object_type_im_category 1
object_type_im_company 1
object_type_im_component_plugin 1
object_type_im_conf_item 1
object_type_im_cost 1
object_type_im_cost_center 1
object_type_im_dynfield_attribute 1
object_type_im_employee 1
object_type_im_expense 1
object_type_im_expense_bundle 1
object_type_im_forum_topic 1
object_type_im_forum_topic_name 1
object_type_im_fs_file 1
object_type_im_hour 1
object_type_im_indicator 1
object_type_im_invoice 1
object_type_im_invoice_item 1
object_type_im_material 1
object_type_im_menu 1
object_type_im_office 1
object_type_im_payment 1
object_type_im_profile 1
object_type_im_project 1
object_type_im_report 1
object_type_im_ticket 1
object_type_im_ticket_ticket_rel 1
object_type_im_timesheet_invoice 1
object_type_im_timesheet_price 1
object_type_im_timesheet_task 1
object_type_im_user_absence 1
object_type_im_view 1
object_type_object 1
object_type_party 1
object_type_person 1
object_type_user 1
}
# ---------------------------------------------------------
# Calculate the columns of the list
# ---------------------------------------------------------
set list_columns {
object_gif {
display_template {@object_types.object_type_gif_html;noquote@}
label ""
}
object_type {
display_col object_type
label "Object Type"
link_url_eval $object_type_url
}
pretty_name {
display_col pretty_name
label "Pretty Name"
}
}
set profile_sql "
select DISTINCT
g.group_name,
g.group_id,
p.profile_gif
from acs_objects o,
groups g,
im_profiles p
where g.group_id = o.object_id
and g.group_id = p.profile_id
and o.object_type = 'im_profile'
and g.group_id != [im_profile_po_admins]
"
set multirow_select ""
set multirow_extend {object_type_url object_type_gif_html crud_status object_wiki_url wiki}
set group_ids [list]
if {$current_user_is_admin_p} {
db_foreach profiles $profile_sql {
regsub -all {[^a-zA-Z0-9]} [string tolower $group_name] "_" group_name_key
lappend list_columns p$group_id
lappend list_columns [list \
label [im_gif -translate_p 0 $profile_gif $group_name $group_name] \
display_template "@object_types.p$group_id;noquote@" \
]
append multirow_select "\t\t, im_object_permission_p(rot.object_type_id, $group_id, 'read') as p${group_id}_read_p\n"
append multirow_select "\t\t, im_object_permission_p(rot.object_type_id, $group_id, 'write') as p${group_id}_write_p\n"
lappend multirow_extend "p$group_id"
lappend group_ids $group_id
}
}
lappend list_columns crud_status
lappend list_columns {
label "CRUL Status"
display_template "@object_types.crud_status;noquote@"
}
lappend list_columns wiki
lappend list_columns {
label "Wiki"
link_url_eval $object_wiki_url
}
# ---------------------------------------------------------
# Create the list and fill it with data
# ---------------------------------------------------------
list::create \
-name object_types \
-multirow object_types \
-key object_type \
-row_pretty_plural "Object Types" \
-checkbox_name checkbox \
-selected_format "normal" \
-class "list" \
-main_class "list" \
-sub_class "narrow" \
-elements $list_columns
db_multirow -extend $multirow_extend object_types select_object_types "
select
ot.object_type,
ot.pretty_name,
ot.object_type_gif,
rot.object_type_id,
im_object_permission_p(rot.object_type_id, :current_user_id, 'read') as current_user_read_p
$multirow_select
from
acs_object_types ot,
im_rest_object_types rot
where
ot.object_type = rot.object_type and
-- skip a number of uninteresting user types
ot.object_type not in ($not_in_object_type)
-- exclude object types created for workflows
and ot.object_type not like '%wf'
order by
ot.object_type
" {
set object_type_url "/intranet-rest/$object_type?format=html"
set object_type_gif_html [im_gif $object_type_gif]
switch $object_type {
im_company - im_project - bt_bug - im_company - im_cost - im_conf_item - im_project - im_user_absence - im_office - im_ticket - im_timesheet_task - im_translation_task - user {
# These object are handled via custom permissions:
}
default {
if {"t" != $current_user_read_p} { set object_type_url "" }
}
}
set crud_status "RUL"
if {[info exists crud_hash($object_type)]} { set crud_status $crud_hash($object_type) }
set wiki_key "object_type_$object_type"
set wiki "Wiki"
regsub -all {_} $object_type {-} object_type_dashes
set object_wiki_url "http://www.project-open.com/en/object-type-$object_type_dashes"
if {![info exists wiki_hash($wiki_key)]} {
set wiki ""
set object_wiki_url ""
}
# Calculate the read/write URLS
foreach gid $group_ids {
set read_p [set "p${gid}_read_p"]
set write_p [set "p${gid}_write_p"]
set object_id $object_type_id
set horiz_group_id $gid
set action "add_readable"
set letter "r"
if {$read_p == "t"} {
set action "remove_readable"
set letter "R"
}
set read "$letter"
set action "add_writable"
set letter "w"
if {$write_p == "t"} {
set action "remove_writable"
set letter "W"
}
set write "$letter"
ns_log Notice "intranet-rest/index: p$gid=gid=$gid, object_id=$object_type_id"
set p$gid "$read$write"
}
}
# End of HTML stuff
}
}
intranet-rest-v5-0-2-4-1/www/version.adp 0000664 0000000 0000000 00000000343 13175625757 0020021 0 ustar 00root root 0000000 0000000 @json;noquote@@page_title;literal@@context_bar;literal@
@page_title@
@version@
intranet-rest-v5-0-2-4-1/www/version.tcl 0000664 0000000 0000000 00000001433 13175625757 0020040 0 ustar 00root root 0000000 0000000 # /packages/intranet-reste/www/version.tcl
#
# Copyright (C) 2010 ]project-open[
#
# ---------------------------------------------------------
# Returns a version string.
# Changes in the major number of the version
# indicate incompatibilites, while changes in
# the minor number mean upgrades.
#
# Please see www.project-open.com/en/rest-version-history
set version [im_rest_version]
if {![info exists format]} { set format "json" }
set rest_url "[im_rest_system_url]/intranet-rest"
# Got a user already authenticated by Basic HTTP auth or auto-login
switch $format {
json {
set json_p 1
set json "{\"success\": true, \"version\": \"$version\"}"
}
default {
set json_p 0
set page_title [lang::message::lookup "" intranet-rest "REST Version"]
set context_bar ""
}
}