Skip to content

I
intranet-rest
Commit bb8c7671 authored by Frank Bergmann's avatar Frank Bergmann
Browse files
Options

- REST: 

  Working on new-delete procs
parent 028fddd8
Hide whitespace changes
Inline Side-by-side
Showing with 205 additions and 50 deletions
perl/ProjectOpen.pm
View file @ bb8c7671
...@@ -186,6 +186,50 @@ sub _http_post_request { ...@@ -186,6 +186,50 @@ sub _http_post_request {
} }
# 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. # Retreive a list of objects of a certain type.
# Example: get_object_list("im_conf_item"); # Example: get_object_list("im_conf_item");
# Parameters: # Parameters:
......
perl/test-new-delete.perl
View file @ bb8c7671
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
# (c) 2014 ]project-open[ # (c) 2014 ]project-open[
# Frank Bergmann (frank.bergmann@project-open.com) # Frank Bergmann (frank.bergmann@project-open.com)
# #
# Tests creation and destruction of certain objects # Tests the REST "update" operation for all object types
# -------------------------------------------------------- # --------------------------------------------------------
...@@ -25,11 +25,11 @@ use ProjectOpen; ...@@ -25,11 +25,11 @@ use ProjectOpen;
# -------------------------------------------------------- # --------------------------------------------------------
# Parameters: # Parameters:
# #
my $debug = 4; # Debug: 0=silent, 9=verbose my $debug = 0; # Debug: 0=silent, 9=verbose
my $rest_host = "demo.project-open.net"; # May include port number, but no trailing "/" my $rest_host = "demo.project-open.net"; # May include port number, but no trailing "/"
my $rest_email = "bbigboss\@tigerpond.com"; # Email for basic auth, needs to be Admin my $rest_email = "sysadmin\@tigerpond.com"; # Email for basic auth, needs to be Admin
my $rest_password = "ben"; # Password for basic authentication my $rest_password = "system"; # Password for basic authentication
$rest_host = "localhost:8000"; $rest_host = "localhost:8000";
my $result = GetOptions ( my $result = GetOptions (
...@@ -40,6 +40,76 @@ my $result = GetOptions ( ...@@ -40,6 +40,76 @@ my $result = GetOptions (
) or die "Usage:\n\ntest-new-delete.perl --debug 1 --host localhost:8000 --email bbigboss\@tigerpond.com --password ben\n\n"; ) 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 SLA (Service Level Agreement) 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 # Request the result
# #
...@@ -50,17 +120,15 @@ $req->authorization_basic($rest_email, $rest_password); ...@@ -50,17 +120,15 @@ $req->authorization_basic($rest_email, $rest_password);
my $response = $ua->request($req); my $response = $ua->request($req);
my $body = $response->content; my $body = $response->content;
print STDERR "test-new-delete.perl: HTTP body=$body\n" if ($debug > 8); print STDERR "test-new-delete.perl: HTTP body=$body\n" if ($debug > 8);
my $return_code = $response->code; my $return_code = $response->code;
if (200 != $return_code) { if (200 != $return_code) {
print "test-new-delete.perl: update all object types 0 $url return_code=$return_code, message=$body\n"; print "test-new-delete.perl: list all object types 0 $url return_code=$return_code, message=$body\n";
exit 1; exit 1;
} }
my $json; my $json;
eval { $json = decode_json($body); }; eval { $json = decode_json($body); };
if ($@) { if ($@) {
print "test-new-delete.perl: update all object types 0 $url Failed to parse JSON, json=$body\n"; print "test-new-delete.perl: list all object types 0 $url Failed to parse JSON, json=$body\n";
exit 1; exit 1;
} }
...@@ -73,46 +141,81 @@ if (!$successfull_p || $debug > 1) { ...@@ -73,46 +141,81 @@ if (!$successfull_p || $debug > 1) {
} }
# --------------------------------------------------------
# Create a generic access object to query the ]po[ HTTP server
#
ProjectOpen->new (
host => $rest_host,
email => $rest_email,
password => $rest_password,
debug => $debug
);
# ------------------------------------------------------- # -------------------------------------------------------
# Create a new Project # 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);
my $r = int(1000000000.0 * rand() * 1000000000.0);
my $random_project_name = "New Project #" . $r;
my $project_hash = {
"project_name" => "New Project #$r",
"project_nr" => "new_project_$r",
"project_status_id" => 76,
"project_type_id" => 2501
};
$url = "http://$rest_host/intranet-rest/im_project";
$result = ProjectOpen->_http_post_request($url, $project_hash);
$success = $result->{'success'};
$message = $result->{'message'};
my $project_id = $result->{'data'}[0];
# print Dumper($project_id). "\n";
$successfull_p = ($success eq "true");
if (!$successfull_p || $debug > 0) {
print "test-new-delete.perl: create new im_project $successfull_p $url success=$success, message=$message\n";
} }
exit 0; exit 0;
tcl/intranet-rest-create-procs.tcl
View file @ bb8c7671
...@@ -187,9 +187,17 @@ ad_proc -private im_rest_post_object_type_im_ticket { ...@@ -187,9 +187,17 @@ ad_proc -private im_rest_post_object_type_im_ticket {
set ticket_note "" set ticket_note ""
set hash_array(ticket_note) $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 # Check that all required variables are there
set required_vars {project_name parent_id ticket_status_id ticket_type_id} set required_vars {project_name parent_id}
foreach var $required_vars { foreach var $required_vars {
if {![info exists $var]} { 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"] return [im_rest_error -format $format -http_status 406 -message "Variable '$var' not specified. The following variables are required: $required_vars"]
...@@ -215,7 +223,7 @@ ad_proc -private im_rest_post_object_type_im_ticket { ...@@ -215,7 +223,7 @@ ad_proc -private im_rest_post_object_type_im_ticket {
# Check for valid parent_id # Check for valid parent_id
set company_id [db_string ticket_company "select company_id from im_projects where project_id = :parent_id" -default ""] set company_id [db_string ticket_company "select company_id from im_projects where project_id = :parent_id" -default ""]
if {"" == $company_id} { 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 'Service Level Agreement'."] 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 'Service Level Agreement'. This SLA will become the container for the ticket."]
} }
if {[catch { if {[catch {
...@@ -705,7 +713,7 @@ ad_proc -private im_rest_post_object_type_im_user_absence { ...@@ -705,7 +713,7 @@ ad_proc -private im_rest_post_object_type_im_user_absence {
set rest_oid [db_string new_absence " set rest_oid [db_string new_absence "
SELECT im_user_absence__new( SELECT im_user_absence__new(
:absence_id, null,
'im_user_absence', 'im_user_absence',
now(), now(),
:rest_user_id, :rest_user_id,
...@@ -713,7 +721,7 @@ ad_proc -private im_rest_post_object_type_im_user_absence { ...@@ -713,7 +721,7 @@ ad_proc -private im_rest_post_object_type_im_user_absence {
null, null,
:absence_name, :absence_name,
:absence_owner_id, :owner_id,
$start_date_sql, $start_date_sql,
$end_date_sql, $end_date_sql,
......
tcl/intranet-rest-post-procs.tcl
View file @ bb8c7671
...@@ -394,12 +394,12 @@ ad_proc -private im_rest_delete_object { ...@@ -394,12 +394,12 @@ ad_proc -private im_rest_delete_object {
# Destroy the object. Try first with an object_type_nuke TCL procedure. # Destroy the object. Try first with an object_type_nuke TCL procedure.
set destroyed_err_msg "" set destroyed_err_msg ""
if {[catch {
set nuke_tcl [list "${nuke_otype}_nuke" -current_user_id $rest_user_id $rest_oid] 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" ns_log Notice "im_rest_delete_object: nuke_tcl=$nuke_tcl"
eval $nuke_tcl eval $nuke_tcl
if {[catch {
} err_msg]} { } err_msg]} {
ns_log Notice "im_rest_delete_object: Error nuking object $rest_oid using TCL code" ns_log Notice "im_rest_delete_object: Error nuking object $rest_oid using TCL code: $err_msg"
set destroyed_p 0 set destroyed_p 0
append destroyed_err_msg "$err_msg\n" append destroyed_err_msg "$err_msg\n"
} else { } else {
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment