LP 1691856: Update README
[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, ext_ent_handler => sub { die('XXE'); } ); };
107     if ($@) {
108         if ($@ eq 'XXE') {
109             $log->warn('Possible XML External Entity Attack...Bailing out');
110             return;
111         }
112         $log->info("Invalid xml we can not parse it ");
113
114     }
115     if ($dom) {
116
117         # should check validity with validate at this point
118         if ( $strict_validation && !$self->validate($dom) ) {
119
120             # we want strict validation, bail out if dom doesnt validate
121 #            warn " Not valid xml";
122
123             # throw/log error
124             return;
125         }
126         return XMLin( $dom, NsStrip => 1, NormaliseSpace => 2 );
127     }
128     else {
129         $log->info("We have no DOM");
130
131         return;
132     }
133 }
134
135 sub validate {
136
137     # this should perhaps be in it's own module
138     my $self = shift;
139     my $dom  = shift;
140     try {
141         $dom->validate();
142     }
143     catch {
144         warn "Bad xml, caught error: $_";
145         return;
146     };
147
148     # we could validate against the schema here, might be good?
149     # my $schema = XML::LibXML::Schema->new(string => $schema_str);
150     # eval { $schema->validate($dom); }
151     # perhaps we could check the ncip version and validate that too
152     return 1;
153 }
154
155 =head2 render_output
156
157   my $output = $self->render_output($response);
158
159 Accepts a NCIP::Response object and renders the response.tt template
160 based on its input.  The template output is returned.
161
162 =cut
163
164 sub render_output {
165     my $self         = shift;
166     my $response = shift;
167
168     my $template = Template->new(
169         {
170             INCLUDE_PATH => $self->config->('NCIP.templates.value'),
171             POST_CHOMP   => 1
172         }
173     );
174
175     my $output;
176     $template->process( 'response.tt', $response, \$output );
177     return $output;
178 }
179
180 1;