Fix a little something caught by perl -c.
[working/NCIPServer.git] / lib / NCIP.pm
1 package NCIP;
2 use NCIP::Configuration;
3 use NCIP::Response;
4 use NCIP::Problem;
5 use Modern::Perl;
6 use XML::LibXML;
7 use XML::LibXML::Simple qw/XMLin/;
8 use Try::Tiny;
9 use Module::Load;
10 use Template;
11 use Log::Log4perl;
12
13 use Object::Tiny qw{config namespace ils};
14
15 our $VERSION           = '0.01';
16 our $strict_validation = 0;        # move to config file
17
18 =head1 NAME
19   
20     NCIP
21
22 =head1 SYNOPSIS
23
24     use NCIP;
25     my $nicp = NCIP->new($config_dir);
26
27 =head1 FUNCTIONS
28
29 =cut
30
31 sub new {
32     my $proto      = shift;
33     my $class      = ref $proto || $proto;
34     my $config_dir = shift;
35     my $self       = {};
36     my $config     = NCIP::Configuration->new($config_dir);
37     $self->{config}    = $config;
38     $self->{namespace} = $config->('NCIP.namespace.value');
39     Log::Log4perl->init($config_dir . "/log4perl.conf");
40     # load the ILS dependent module
41     my $module = $config->('NCIP.ils.value');
42     load $module || die "Can not load ILS module $module";
43     my $ils = $module->new( name => $config->('NCIP.ils.value') );
44     $self->{'ils'} = $ils;
45     return bless $self, $class;
46
47 }
48
49 =head2 process_request()
50
51  my $output = $ncip->process_request($xml);
52
53 =cut
54
55 sub process_request {
56     my $self           = shift;
57     my $xml            = shift;
58
59     # Declare our response object:
60     my $response;
61
62     # Make an object out of the XML request message:
63     my $request = $self->handle_initiation($xml);
64     if ($request) {
65         # Get the request type from the message:
66         my $type = $self->{ils}->parse_request_type($request);
67         if ($type) {
68             my $message = lc($type);
69             if ($self->{ils}->can($message)) {
70                 $response = $self->{ils}->$message($request);
71             } else {
72                 $response = $self->{ils}->unsupportedservice($request);
73             }
74         }
75     }
76
77     # The ILS is responsible for handling internal errors, so we
78     # assume that not having a response object at this point means we
79     # got an invalid message sent to us, or it got garbled in
80     # transmission.
81     unless ($response) {
82         my $problem = NCIP::Problem->new();
83         $problem->ProblemType("Invalid Message Syntax Error");
84         $problem->ProblemDetail("Unable to parse the NCIP message.");
85         $problem->ProblemElement("NULL");
86         $problem->ProblemValue("Unable to parse the NCIP message.");
87         # Make a response and add our problem.
88         $response = NCIP::Response->new();
89         $response->problem($problem);
90     }
91
92     return $self->render_output($response);
93 }
94
95 =head2 handle_initiation
96
97 =cut
98
99 sub handle_initiation {
100     my $self = shift;
101     my $xml  = shift;
102
103     my $dom;
104     my $log = Log::Log4perl->get_logger("NCIP");
105
106     eval { $dom = XML::LibXML->load_xml( string => $xml ); };
107     if ($@) {
108         $log->info("Invalid xml we can not parse it ");
109     }
110     if ($dom) {
111
112         # should check validity with validate at this point
113         if ( $strict_validation && !$self->validate($dom) ) {
114
115             # we want strict validation, bail out if dom doesnt validate
116 #            warn " Not valid xml";
117
118             # throw/log error
119             return;
120         }
121         return XMLin( $dom, NsStrip => 1, NormaliseSpace => 2 );
122     }
123     else {
124         $log->info("We have no DOM");
125
126         return;
127     }
128 }
129
130 sub validate {
131
132     # this should perhaps be in it's own module
133     my $self = shift;
134     my $dom  = shift;
135     try {
136         $dom->validate();
137     }
138     catch {
139         warn "Bad xml, caught error: $_";
140         return;
141     };
142
143     # we could validate against the schema here, might be good?
144     # my $schema = XML::LibXML::Schema->new(string => $schema_str);
145     # eval { $schema->validate($dom); }
146     # perhaps we could check the ncip version and validate that too
147     return 1;
148 }
149
150 =head2 render_output
151
152   my $output = $self->render_output($response);
153
154 Accepts a NCIP::Response object and renders the response.tt template
155 based on its input.  The template output is returned.
156
157 =cut
158
159 sub render_output {
160     my $self         = shift;
161     my $response = shift;
162
163     my $template = Template->new(
164         {
165             INCLUDE_PATH => $self->config->('NCIP.templates.value'),
166             POST_CHOMP   => 1
167         }
168     );
169
170     my $output;
171     $template->process( 'response.tt', $response, \$output );
172     return $output;
173 }
174
175 1;