[Bio] / FigKernelPackages / SSserver.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/SSserver.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (view) (download) (as text)

1 : disz 1.1 package SSserver;
2 :    
3 : olson 1.4 #
4 : parrello 1.9 # This is a SAS Component
5 : olson 1.4 #
6 :    
7 : disz 1.1 use LWP::UserAgent;
8 :     use YAML;
9 : parrello 1.11 use ErrorMessage;
10 :     no warnings qw(once);
11 : disz 1.1
12 :     use strict;
13 :    
14 : parrello 1.10 =head1 Subsystem Server Helper Object
15 :    
16 :     =head2 Description
17 :    
18 :     This module is used to call the Subsystem Server, which is a special-purpose
19 :     server for manipulating subsystem data from the Sapling database. Each Subsystem
20 :     Server function corresponds to a method of this object.
21 :    
22 :     This package deliberately uses no internal SEED packages or scripts, only common
23 :     PERL modules.
24 :    
25 :     The fields in this object are as follows.
26 :    
27 :     =over 4
28 :    
29 :     =item server_url
30 :    
31 :     The URL used to request data from the subsystem server.
32 :    
33 :     =item ua
34 :    
35 :     The user agent for communication with the server.
36 :    
37 :     =item singleton
38 :    
39 :     Indicates whether or not results are to be returned in singleton mode. In
40 :     singleton mode, if the return document is a hash reference with only one
41 :     entry, the entry value is returned rather than the hash.
42 :    
43 :     =back
44 :    
45 :     =cut
46 :    
47 :     =head3 new
48 :    
49 :     my $ss = SSserver->new(%options);
50 :    
51 : parrello 1.11 Construct a new server object. The
52 :     following options are supported.
53 : parrello 1.10
54 :     =over 4
55 :    
56 :     =item url
57 :    
58 : parrello 1.11 URL for the server. This option is required.
59 : parrello 1.10
60 : parrello 1.11 =item singleton (optional)
61 : parrello 1.10
62 :     If TRUE, results from methods will be returned in singleton mode. In singleton
63 :     mode, if a single result comes back, it will come back as a scalar rather than
64 :     as a hash value accessible via an incoming ID.
65 :    
66 :     =back
67 :    
68 :     =cut
69 :    
70 :     sub new {
71 :     # Get the parameters.
72 :     my ($class, %options) = @_;
73 : parrello 1.11 # Turn off YAML compression, which causes problems with our hash keys.
74 :     $YAML::CompressSeries = 0;
75 : parrello 1.10 # Get the options.
76 : parrello 1.12 my $url = $options{url} || "http://servers.nmpdr.org/subsystem/server.cgi";
77 : parrello 1.10 my $singleton = $options{singleton} || 0;
78 : parrello 1.11 # Create the fields of the object. Note that if we're in localhost mode,
79 :     # the user agent is actually a SAP object.
80 : parrello 1.10 my $server_url = $url;
81 : parrello 1.11 my $ua;
82 :     if ($server_url ne 'localhost') {
83 :     require LWP::UserAgent;
84 :     $ua = LWP::UserAgent->new();
85 : olson 1.13 $ua->timeout(20 * 60);
86 : parrello 1.11 } else {
87 :     require "SS.pm";
88 :     $ua = SS->new();
89 :     }
90 :     # Create the server object.
91 : parrello 1.10 my $retVal = {
92 :     server_url => $server_url,
93 :     ua => $ua,
94 :     singleton => $singleton,
95 :     };
96 : parrello 1.11 # Bless it.
97 : parrello 1.10 bless $retVal, $class;
98 : parrello 1.11 # Get the list of permitted methods from the server.
99 :     my $methodList = $retVal->_call_method(methods => []);
100 :     # Convert it to a hash and store it in this object.
101 :     $retVal->{methodHash} = { map { $_ => 1 } @$methodList };
102 :     # Return the object.
103 : parrello 1.10 return $retVal;
104 : disz 1.1 }
105 :    
106 : parrello 1.10 =head3 AUTOLOAD
107 : disz 1.1
108 : parrello 1.11 my $result = $server->method(%args);
109 : disz 1.1
110 : parrello 1.10 Call a function on the server. Any method call on this object (other than
111 :     the constructor) is translated into a request against the server. This
112 :     enables us to add new server functions without requiring an update to this
113 : parrello 1.11 object or its parent. The parameters are usually specified as a hash, and the
114 :     result is a scalar or object reference. In some cases the parameters are a list.
115 :     To deistinguish between the two cases, all hash keys must begin with hyphens.
116 :    
117 :     If an error occurs, we will throw an exception.
118 : disz 1.1
119 : parrello 1.10 =cut
120 : disz 1.1
121 : parrello 1.10 # This variable will contain the method name.
122 :     our $AUTOLOAD;
123 : disz 1.5
124 : parrello 1.10 sub AUTOLOAD {
125 :     # Get the parameters. We do some fancy dancing to allow the user to pass
126 : parrello 1.11 # in a hash, a list, a list reference, or a hash reference.
127 : parrello 1.10 my $self = shift @_;
128 :     my $args = $_[0];
129 :     if (defined $args) {
130 :     if (scalar @_ gt 1) {
131 :     # Here we have multiple arguments. We check the first one for a
132 :     # leading hyphen.
133 :     if ($args =~ /^-/) {
134 :     # This means we have hash-form parameters.
135 :     my %args = @_;
136 :     $args = \%args;
137 :     } else {
138 :     # This means we have list-form parameters.
139 :     my @args = @_;
140 :     $args = \@args;
141 : disz 1.1 }
142 : parrello 1.10 } else {
143 :     # Here we have a single argument. If it's a scalar, we convert it
144 :     # to a singleton list.
145 :     if (! ref $args) {
146 :     $args = [$args];
147 : disz 1.1 }
148 : parrello 1.10 }
149 :     }
150 :     # Declare the return variable.
151 :     my $retVal;
152 :     # Get the method name.
153 :     my $function = $AUTOLOAD;
154 :     # Strip off the stuff before the method name.
155 :     $function =~ s/.+:://;
156 : parrello 1.11 # Validate the method name.
157 :     if (! $self->{methodHash}{$function}) {
158 :     die "Method \"$function\" not supported.";
159 : parrello 1.10 } else {
160 : parrello 1.11 # Call the method.
161 :     $retVal = $self->_call_method($function, $args);
162 :     # We have our result. Adjust for singleton mode.
163 :     if ($self->{singleton} && ref $retVal eq 'HASH' && scalar(keys %$retVal) <= 1) {
164 :     # Here we're in singleton mode and we got a single result,
165 :     # so we dereference a bit to make it easier for the user
166 :     # to access it.
167 :     ($retVal) = values %$retVal;
168 : parrello 1.10 }
169 :     }
170 :     # Return the result.
171 :     return $retVal;
172 : disz 1.1 }
173 :    
174 : parrello 1.10 =head3 DESTROY
175 :    
176 :     $ss->DESTROY();
177 :    
178 :     This method has no function. It's purpose is to keep the destructor from
179 :     being caught by the autoload processing.
180 :    
181 :     =cut
182 :    
183 :     sub DESTROY { }
184 :    
185 : parrello 1.11 =head2 Utility Methods
186 :    
187 :     =head3 _call_method
188 :    
189 :     my $result = $server->_call_method($method, $args);
190 :    
191 :     Call the specified method on the server with the specified arguments and
192 :     return the result. The arguments must already be packaged as a hash or
193 :     list reference. This method is the heart of the AUTOLOAD method, and is
194 :     provided as a utility for specialized methods that can't use the AUTOLOAD
195 :     facility.
196 :    
197 :     =over 4
198 :    
199 :     =item method
200 :    
201 :     Name of the server function being invoked.
202 :    
203 :     =item args
204 :    
205 :     Argument object to pass to the function.
206 :    
207 :     =item RETURN
208 :    
209 :     Returns a hash or list reference with the function results.
210 :    
211 :     =back
212 :    
213 :     =cut
214 :    
215 :     sub _call_method {
216 :     # Get the parameters.
217 :     my ($self, $method, $args) = @_;
218 :     # Declare the return variable.
219 :     my $retVal;
220 :     # Get our user agent.
221 :     my $ua = $self->{ua};
222 :     # Determine the type.
223 :     if (ref $ua eq 'LWP::UserAgent') {
224 :     # Here we're going to a server. Compute the argument document.
225 :     my $argString = YAML::Dump($args);
226 :     # Request the function from the server.
227 :     my $content = $self->_send_request(function => $method, args => $argString,
228 :     source => __PACKAGE__);
229 :     $retVal = YAML::Load($content);
230 :     } else {
231 :     # Here we're calling a local method.
232 :     $retVal = eval("\$ua->$method(\$args)");
233 :     # Check for an error.
234 :     if ($@) {
235 :     die "Package error: $@";
236 :     }
237 :     }
238 :     # Return the result.
239 :     return $retVal;
240 :     }
241 :    
242 :     =head3 _send_request
243 :    
244 :     my $result = $server->_send_request(%parms);
245 :    
246 :     Send a request to the server. This method must not be called in localhost
247 :     mode. If an error occurs, this method will die; otherwise, the content of
248 :     the response will be passed back as the result.
249 :    
250 :     =over 4
251 :    
252 :     =item parms
253 :    
254 :     Hash of CGI parameters to send to the server.
255 :    
256 :     =item RETURN
257 :    
258 :     Returns the string returned by the server in response to the request.
259 :    
260 :     =back
261 :    
262 :     =cut
263 :    
264 :     sub _send_request {
265 :     # Get the parameters.
266 :     my ($self, %parms) = @_;
267 :     # Get the user agent.
268 :     my $ua = $self->{ua};
269 :     # Request the function from the server. Note that the hash is actually passed
270 :     # as a list reference.
271 : olson 1.14
272 :     #
273 :     # retries is the set of retry wait times in seconds we should use. when
274 :     # we run out the call will fail.
275 :     #
276 :    
277 :     my @retries = (1, 2, 5, 10, 20, 60, 60, 60, 60, 60, 60);
278 :     my %codes_to_retry = map { $_ => 1 } qw(110 408 502 503 504 200) ;
279 :    
280 :     while (1)
281 :     {
282 :     my $response = $ua->post($self->{server_url}, [ %parms ]);
283 :    
284 :     if ($response->is_success)
285 :     {
286 :     my $retVal = $response->content;
287 :     return $retVal;
288 :     }
289 :    
290 :     #
291 :     # If this is not one of the error codes we retry for, or if we
292 :     # are out of retries, fail immediately
293 :     #
294 :     my $code = $response->code;
295 :     if (!$codes_to_retry{$code} || @retries == 0)
296 :     {
297 :     die ErrorMessage->new($response->content, $response->status_line);
298 :     }
299 :    
300 :     #
301 :     # otherwise, sleep & loop.
302 :     #
303 :     my $retry_time = shift(@retries);
304 :     print STDERR "Request failed with code=$code, sleeping $retry_time and retrying\n";
305 :     sleep($retry_time);
306 :    
307 : parrello 1.11 }
308 : olson 1.14
309 :     #
310 :     # Should never get here.
311 :     #
312 : parrello 1.11 }
313 :    
314 : disz 1.1
315 : parrello 1.10 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3