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;