Some -> fixes
[opensuse:sxkeeper.git] / perl / SXKeeper / Access.pm
1  # -----------------------------------------------------------
2 # SUSE Inttools Codebase
3 # (c)2005 SUSE LINUX Products GmbH, Nuernberg
4 # -----------------------------------------------------------
5 # Contributor(s):
6 # Christopher Hofmann <cwh@suse.de>
7 # Andreas Bauer <abauer@suse.de>
8 # Klaas Freitag <freitag@suse.de>
9 # -----------------------------------------------------------
10 package SXKeeper::Access;
11
12 use strict;
13 use URI;
14 use Carp;
15 use LWP::UserAgent;
16 use Encode qw( encode _utf8_off );
17 use Params::Validate qw( :all );
18 use Regexp::Common qw( URI );
19
20 use vars qw( $VERSION );
21
22 $VERSION = 0.94;
23
24 #----------------------------------------------------
25 # new()
26 #----------------------------------------------------
27 # constructor
28 #
29 # named parameters:
30 #       url:    location of keeper
31 #       logger: Log::Dispatch object to log output to
32 #       debug:  log also debug messages
33 #       agent:  Set user-agent string sent to server; default: "KeeperAccess/$VERSION"
34
35 sub new
36 {
37     my $class = shift;
38     my $self = {};
39     bless( $self, $class );
40     
41     my %params = validate( @_,
42                            { url => { type      => SCALAR,
43                                       optional => 0 },
44                              logger => { type => OBJECT,
45                                          optional => 1 },
46                              debug => { optional => 1 },
47                              agent => { default => "KeeperAccess/$VERSION" },
48                              charset => { default => 'UTF-8' },
49                              username => { optional => 1 },
50                              password => { optional => 1 },
51                              return_response_object => { type => SCALAR,
52                                                          default => 0 } } );
53
54     $self->{ua} = LWP::UserAgent->new( agent => $params{'agent'},
55                                        timeout => 60,
56                                        env_proxy => 0 );
57
58     $self->{charset} = $params{'charset'};
59
60     $self->{ua_default_header} = { 'Accept' => 'text/*; charset='.$self->{charset} };
61
62     unless( $params{url} =~ /$RE{URI}{HTTP}/ )
63     {
64         croak( "Invalid URL: '$params{url}'" );
65     }
66
67     if( exists $params{logger} && $params{logger}->isa("Log::Dispatch") )
68     {
69         $self->{logger} = $params{logger};
70     }
71
72     foreach( 'url', 'debug', 'username', 'password', 'return_response_object' )
73     {
74         $self->{$_} = $params{$_};
75     }
76
77     $self->{url} .= '/' unless( $params{url} =~ /\/$/ );
78
79     $self->log("debug", "created object") if( $self->{debug} );
80
81     $self->{metafiles} = ();
82
83     return $self;
84 }
85
86 #----------------------------------------------------
87 # getStaticContent($path)
88 #----------------------------------------------------
89
90 sub getStaticContent
91 {
92     my ( $self, $path ) = validate_pos( @_,
93                                         { isa => __PACKAGE__ },              # $self
94                                         { type => SCALAR, optional => 0 } ); # path
95
96     my $uri = URI->new( $self->{url}.$path );
97
98     return $self->askKeeper( $uri );
99 }
100
101 sub getMetaFile
102 {
103   my ( $self, $id ) = validate_pos( @_,
104                                     { isa => __PACKAGE__ },              # $self
105                                     { type => SCALAR, optional => 0 } ); # id
106
107   $self->loadMetaDescriptor(); # do that always, because meta revisions can change always.
108
109   my $descriptorRef = $self->{metafiles}{$id};
110   if ( $descriptorRef ) {
111     return $self->getStaticContent( $descriptorRef->{location} );
112   }
113 }
114
115 sub loadMetaDescriptor
116 {
117   my ( $self ) = validate_pos( @_,
118                                { isa => __PACKAGE__ } );             # $self
119
120   my $uri = URI->new( $self->{url} . "meta/feature" );
121   $self->log( 'debug', "fetching meta description $uri" );
122   my $content = $self->askKeeper( $uri )->decoded_content();
123
124   # Parse xml and build a id -> static_path map
125   my $xmlParser = XML::LibXML->new();
126   my $dom = $xmlParser->parse_string( $content );
127
128   my $res = $dom->findnodes( 'meta/resource' );
129   $self->{metafiles} = () if( $res );
130
131   foreach my $resource ( $res->get_nodelist ) {
132     my $id = $resource->getAttribute( 'id' );
133     my $rev = $resource->getAttribute( 'revision' );
134     my $location  = $resource->getAttribute( 'location' );
135
136     $self->{metafiles}{$id} = { id => $id,
137                                 revision => $rev,
138                                 location => $location };
139   }
140 }
141
142 #----------------------------------------------------
143 # getSingleDocument( $container, $xquery )
144 #----------------------------------------------------
145 # Parameters:
146 #    $container - name of the container, e.g. 'feature'
147 #    $id - optional - id of the wanted document or empty string for all documents
148 #
149 # Return Value:
150 #    string containing XML; root element depends on result's content (root element = name of container)
151 #
152 #
153
154 sub getSingleDocument
155 {
156     my ( $self, $container, $id, $rev ) = validate_pos( @_,
157                                                         { isa => __PACKAGE__ },              # $self
158                                                         { type => SCALAR, optional => 0 },   # Container
159                                                         { type => SCALAR, optional => 0 },   # ID
160                                                         { type => SCALAR, optional => 1 } ); # Revision
161     
162     my $url = $self->{url}."$container/$id";
163     $url .= "/$rev" if( defined $rev );
164
165     my $uri = URI->new( $url );
166
167     return $self->askKeeper( $uri );
168 }
169
170 #----------------------------------------------------
171 # getDocuments( $container [, $query ] )
172 #----------------------------------------------------
173 # Parameters:
174 #    $container - name of the container, e.g. 'feature'
175 #    $xquery - optional
176 #
177 # Return Value:
178 #    string containing XML; root element: <k:collection>...</k:collection>
179 #
180 #
181
182 sub getDocuments
183 {
184     my ( $self, $container, $query ) = validate_pos( @_,
185                                                      { isa => __PACKAGE__ },              # $self
186                                                      { type => SCALAR, optional => 0 },   # Container
187                                                      { type => SCALAR, optional => 1 } ); # XQuery-string
188
189     my $uri = URI->new( $self->{url}."$container/" );
190
191     if( $query )
192     {
193         $uri->query_form( 'query' => $query );
194     }
195
196     return $self->askKeeper( $uri );
197 }
198
199 #----------------------------------------------------
200 # updateDocument( %params )
201 #----------------------------------------------------
202
203 sub updateDocument
204 {
205     my $self = shift;
206
207     croak('Has to be called as a method.') if( ref( $self ) ne __PACKAGE__ );
208
209     my %params = validate( @_,
210                            { container => { type => SCALAR, optional => 0 },
211                              id => { type => SCALAR, optional => 0 },
212                              data => { type => SCALAR, optional => 0 },
213                              params => { type => HASHREF, optional => 1 },
214                              username => { type => SCALAR, optional => 1 },
215                              password => { type => SCALAR, optional => 1 } }  );
216
217     my ( $container, $id, $data, $query_params, $username, $password ) =
218         @params{ 'container', 'id', 'data', 'params', 'username', 'password' };
219
220     unless( $username && $password )
221     {
222         $username = $self->{username};
223         $password = $self->{password};
224     }
225    
226
227
228     my $uri = URI->new( $self->{url}."$container/$id" );
229
230     if( $query_params )
231     {
232         $uri->query_form( $query_params );
233     }
234
235     $self->log( 'debug', "PUT '$uri'" ) if( $self->{debug} );
236
237     my $request = HTTP::Request->new( "PUT", $uri );
238
239     my $header = $request->headers;
240     $header->authorization_basic( $username, $password );
241     $header->header( %{$self->{ua_default_header}} );
242     $header->header( 'Content_Type' => 'text/xml; charset='.$self->{charset} );
243
244     #print STDERR $header->as_string."\n";
245
246     # fill the data in the request to be sent to the keeper:
247
248     # There are problems with "wide characters in syswrite. To fix that I see 2
249     # possible solutions. However I'm not sure which one makes the correct encoding.
250
251     # 1:
252     # _utf8_off($data);
253     #$request->content( $data );
254     # --
255
256     # 2:
257     encode( $self->{charset}, $data);
258     $request->content( $data );
259     # --
260
261     my $response = $self->{ua}->request( $request );
262
263     if( $self->{return_response_object} )
264     {
265         return $response;
266     }
267     else
268     {
269         if( $response->is_success )
270         {
271             $self->log( 'debug', $response->status_line ) if( $self->{debug} );
272             return $response->content();
273         }
274         else
275         {
276             if( $response->content_type() eq 'text/xml' )
277             {
278                 $self->log( 'debug', $response->status_line ) if( $self->{debug} );
279                 return $response->decoded_content();
280             }
281             else
282             {
283                 $self->log( 'error', $response->status_line );
284                 croak( $response->status_line );
285             }
286         }
287     }
288 }
289
290 #----------------------------------------------------
291 # newDocument( %params )
292 #----------------------------------------------------
293
294 sub newDocument
295 {
296     my $self = shift;
297
298     croak('Has to be called as a method.') if( ref( $self ) ne __PACKAGE__ );
299
300     my %params = validate( @_,
301                            { container => { type => SCALAR, optional => 0 },
302                              data => { type => SCALAR, optional => 0 },
303                              params => { type => HASHREF, optional => 1 },
304                              username => { type => SCALAR, optional => 1 },
305                              password => { type => SCALAR, optional => 1 } }  );
306
307     my ( $container, $id, $data, $query_params, $username, $password ) =
308         @params{ 'container', 'id', 'data', 'params', 'username', 'password' };
309
310     unless( $username && $password )
311     {
312         $username = $self->{username};
313         $password = $self->{password};
314     }
315
316     # print STDERR "u:$username, p:$password\n";
317
318     my $uri = URI->new( $self->{url}."$container/" );
319
320     if( $query_params )
321     {
322         $uri->query_form( $query_params );
323     }
324
325     $self->log( 'debug', "POST '$uri'" ) if( $self->{debug} );
326
327     my $request = HTTP::Request->new( "POST", $uri );
328
329     my $header = $request->headers;
330     $header->authorization_basic( $username, $password );
331     $header->header( %{$self->{ua_default_header}} );
332     $header->header( 'Content_Type' => 'text/xml; charset='.$self->{charset} );
333
334     # fill the data in the request to be sent to the keeper:
335     $request->content( encode( $self->{charset}, $data) );
336
337     my $response = $self->{ua}->request( $request );
338
339     if( $self->{return_response_object} )
340     {
341         return $response;
342     }
343     else
344     {
345         if( $response->is_success )
346         {
347             $self->log( 'debug', $response->status_line ) if( $self->{debug} );
348             return $response->content();
349         }
350         else
351         {
352             if( $response->content_type() eq 'text/xml' )
353             {
354                 $self->log( 'debug', $response->status_line ) if( $self->{debug} );
355                 return $response->decoded_content();
356             }
357             else
358             {
359                 $self->log( 'error', $response->status_line );
360                 croak( $response->status_line );
361             }
362         }
363     }
364 }
365
366 #----------------------------------------------------
367 # askKeeper( $url )
368 #----------------------------------------------------
369 # Internal method
370 #
371 # Parameters:
372 #    $url - url to send to the keeper
373 #
374 # Return Value:
375 #
376 #
377 #
378
379 sub askKeeper
380 {
381     my ( $self, $uri ) = validate_pos( @_, { isa => __PACKAGE__ }, 1 );
382
383     $self->log( 'debug', "GET '$uri'" ) if( $self->{debug} );
384
385     my $request = HTTP::Request->new( "GET", $uri );
386     $request->headers->header( %{$self->{ua_default_header}} );
387     $request->headers->authorization_basic( $self->{username},
388                                             $self->{password} ) if( $self->{username} && $self->{password} );
389
390     my $response = $self->{ua}->request( $request );
391     
392     if( $self->{return_response_object} )
393     {
394         return $response;
395     }
396     else
397     {
398         if( $response->is_success )
399         {
400             $self->log( 'debug', "Content-type: ".$response->content_type() ) if( $self->{debug} );
401             return $response->decoded_content();
402         }
403         else
404         {
405             $self->log( 'debug', "Getting $uri failed." ) if( $self->{debug} );
406
407             #print STDERR $response->decoded_content();
408
409             if( $response->content_type() eq 'text/xml' )
410             {
411                 return $response->decoded_content();
412             }
413             else
414             {
415                 croak( $response->status_line );
416             }
417         }
418     }
419 }
420
421 #############################
422 # helper functions
423 #############################
424
425 sub log
426 {
427     my ( $self, $level, $msg ) = validate_pos( @_,
428                                                { isa => __PACKAGE__ },
429                                                { type => SCALAR,
430                                                  optional => 0 },
431                                                { type => SCALAR,
432                                                  optional => 0 } );
433     
434     if( exists $self->{logger} )
435     {
436         $self->{logger}->log( $level, $msg );
437     }
438     else
439     {
440         print STDERR "[$level] KeeperAccess: $msg\n";
441     }
442 }