File Coverage

blib/lib/Device/WebIO/Dancer.pm
Criterion Covered Total %
statement 32 32 100.0
branch 4 6 66.6
condition n/a
subroutine 9 9 100.0
pod 0 1 0.0
total 45 48 93.7


line stmt bran cond sub pod time code
1             package Device::WebIO::Dancer;
2             $Device::WebIO::Dancer::VERSION = '0.004';
3             # ABSTRACT: REST interface for Device::WebIO using Dancer
4 7     7   1170124 use v5.12;
  7         20  
5 7     7   45 use Dancer;
  7         7  
  7         30  
6 7     7   4968 use Time::HiRes 'sleep';
  7         11  
  7         47  
7 7     7   552 use File::Spec;
  7         7  
  7         126  
8              
9 7     7   25 use constant VID_READ_LENGTH => 4096;
  7         9  
  7         326  
10 7     7   22 use constant PULSE_TIME => 0.1;
  7         6  
  7         13605  
11              
12              
13             my ($webio, $default_name, $public_dir);
14              
15             sub init
16             {
17 6     6 0 8935 my ($webio_ext, $default_name_ext, $public_dir_ext) = @_;
18 6         9 $webio = $webio_ext;
19 6         10 $default_name = $default_name_ext;
20 6         7 $public_dir = $public_dir_ext;
21 6         12 return 1;
22             }
23              
24              
25             get '/devices/:name/count' => sub {
26             my $name = params->{name};
27             my $count = $webio->digital_input_pin_count( $name );
28             return $count;
29             };
30              
31             get '/devices/:name/:pin/integer' => sub {
32             my ($name) = params->{name};
33             my ($pin) = params->{pin};
34             my $int = $webio->digital_input_port( $name );
35             return $int;
36             };
37              
38             get '/devices/:name/:pin/value' => sub {
39             my $name = params->{name};
40             my $pin = params->{pin};
41              
42             my $in;
43             if( $pin eq '*' ) {
44             my $int = $webio->digital_input_port( $name );
45             my @values = _int_to_array( $int,
46             reverse(0 .. $webio->digital_input_pin_count( $name ) - 1) );
47             $in = join ',', @values;
48             }
49             else {
50             $in = $webio->digital_input( $name, $pin );
51             }
52             return $in;
53             };
54              
55             get '/devices/:name/:pin/function' => sub {
56             my $name = params->{name};
57             my $pin = params->{pin};
58              
59             my $type = _get_io_type( $name, $pin );
60             return $type;
61             };
62              
63             post '/devices/:name/:pin/function/:func' => sub {
64             my $name = params->{name};
65             my $pin = params->{pin};
66             my $func = uc params->{func};
67              
68             if( 'IN' eq $func ) {
69             $webio->set_as_input( $name, $pin );
70             }
71             elsif( 'OUT' eq $func ) {
72             $webio->set_as_output( $name, $pin );
73             }
74             else {
75             # TODO
76             }
77              
78             return '';
79             };
80              
81             get '/devices/:name/:pin' => sub {
82             my $name = params->{name};
83             my $pin = params->{pin};
84             my $pin_count = $webio->digital_input_pin_count( $name );
85             my @pin_index_list = 0 .. ($pin_count - 1);
86              
87             my (@values, @type_values);
88             foreach (@pin_index_list) {
89             my $type = _get_io_type( $name, $_ );
90             push @type_values, $type;
91              
92             my $int = ($type eq 'IN') ? $webio->digital_input( $name, $_ ) :
93             ($type eq 'OUT') ? 0 :
94             0;
95             push @values, $int;
96             }
97              
98             my $combined_types = join ',', reverse map {
99             $values[$_] . ':' . $type_values[$_]
100             } @pin_index_list;
101             return $combined_types;
102             };
103              
104             post '/devices/:name/:pin/value/:digit' => sub {
105             my $name = params->{name};
106             my $pin = params->{pin};
107             my $digit = params->{digit};
108              
109             $webio->digital_output( $name, $pin, $digit );
110              
111             return '';
112             };
113              
114             post '/devices/:name/:pin/integer/:value' => sub {
115             my $name = params->{name};
116             my $pin = params->{pin};
117             my $value = params->{value};
118              
119             $webio->digital_output_port( $name, $value );
120              
121             return '';
122             };
123              
124             get '/devices/:name/video/count' => sub {
125             my $name = params->{name};
126             my $val = $webio->vid_channels( $name );
127             return $val;
128             };
129              
130             get '/devices/:name/video/:channel/resolution' => sub {
131             my $name = params->{name};
132             my $channel = params->{channel};
133              
134             my $width = $webio->vid_width( $name, $channel );
135             my $height = $webio->vid_height( $name, $channel );
136             my $fps = $webio->vid_fps( $name, $channel );
137              
138             return $width . 'x' . $height . 'p' . $fps;
139             };
140              
141             post '/devices/:name/video/:channel/resolution/:width/:height/:framerate'
142             => sub {
143             my $name = params->{name};
144             my $channel = params->{channel};
145             my $width = params->{width};
146             my $height = params->{height};
147             my $fps = params->{framerate};
148              
149             $webio->vid_set_width( $name, $channel, $width );
150             $webio->vid_set_height( $name, $channel, $height );
151             $webio->vid_set_fps( $name, $channel, $fps );
152              
153             return '';
154             };
155              
156             get '/devices/:name/video/:channel/kbps' => sub {
157             my $name = params->{name};
158             my $channel = params->{channel};
159              
160             my $bitrate = $webio->vid_kbps( $name, $channel );
161              
162             return $bitrate;
163             };
164              
165             post '/devices/:name/video/:channel/kbps/:bitrate' => sub {
166             my $name = params->{name};
167             my $channel = params->{channel};
168             my $bitrate = params->{bitrate};
169             $webio->vid_set_kbps( $name, $channel, $bitrate );
170             return '';
171             };
172              
173             get '/devices/:name/video/:channel/allowed-content-types' => sub {
174             my $name = params->{name};
175             my $channel = params->{channel};
176             my $allowed = $webio->vid_allowed_content_types( $name, $channel );
177             return join( "\n", @$allowed );
178             };
179              
180             get '/devices/:name/video/:channel/stream/:type1/:type2' => sub {
181             my $name = params->{name};
182             my $channel = params->{channel};
183             my $type1 = params->{type1};
184             my $type2 = params->{type2};
185             my $mime_type = $type1 . '/' . $type2;
186              
187             my $in_fh = $webio->vid_stream( $name, $channel, $mime_type );
188              
189             return send_file( '/etc/hosts',
190             streaming => 1,
191             system_path => 1,
192             content_type => $mime_type,
193             callbacks => {
194             around_content => sub {
195             my ($writer, $chunk) = @_;
196              
197             my $buf;
198             while( read( $in_fh, $buf, VID_READ_LENGTH ) ) {
199             $writer->write( $buf );
200             }
201             close $in_fh;
202             }
203             },
204             );
205             };
206              
207             get '/devices/:name/analog/count' => sub {
208             my $name = params->{name};
209             my $count = $webio->adc_count( $name );
210             return $count;
211             };
212              
213             get '/devices/:name/analog/maximum' => sub {
214             # TODO deprecate this more explicitly (301 Moved Permanently?)
215             my $name = params->{name};
216             my $max = $webio->adc_max_int( $name, 0 );
217             return $max;
218             };
219              
220             get '/devices/:name/analog/:pin/maximum' => sub {
221             my $name = params->{name};
222             my $pin = params->{pin};
223             my $max = $webio->adc_max_int( $name, $pin );
224             return $max;
225             };
226              
227             get '/devices/:name/analog/:pin/integer/vref' => sub {
228             my $name = params->{name};
229             my $pin = params->{pin};
230             my $value = $webio->adc_volt_ref( $name, $pin );
231             return $value;
232             };
233              
234             get '/devices/:name/analog/integer/vref' => sub {
235             # TODO deprecate this more explicitly (301 Moved Permanently?)
236             my $name = params->{name};
237             my $value = $webio->adc_volt_ref( $name, 0 );
238             return $value;
239             };
240              
241             get '/devices/:name/analog/:pin/integer' => sub {
242             my $name = params->{name};
243             my $pin = params->{pin};
244              
245             my $value;
246             if( $pin eq '*' ) {
247             my @val = map {
248             $webio->adc_input_int( $name, $_ ) // 0
249             } 0 .. ($webio->adc_count( $name ) - 1);
250             $value = join ',', @val;
251             }
252             else {
253             $value = $webio->adc_input_int( $name, $pin );
254             }
255             return $value;
256             };
257              
258             get '/devices/:name/analog/:pin/float' => sub {
259             my $name = params->{name};
260             my $pin = params->{pin};
261             my $value = $webio->adc_input_float( $name, $pin );
262             return $value;
263             };
264              
265             get '/devices/:name/analog/:pin/volt' => sub {
266             my $name = params->{name};
267             my $pin = params->{pin};
268             my $value = $webio->adc_input_volts( $name, $pin );
269             return $value;
270             };
271              
272             get '/devices/:name/image/count' => sub {
273             my $name = params->{name};
274             my $value = $webio->img_channels( $name );
275             return $value;
276             };
277              
278             get '/devices/:name/image/:pin/resolution' => sub {
279             my $name = params->{name};
280             my $pin = params->{pin};
281             my $width = $webio->img_width( $name, $pin );
282             my $height = $webio->img_height( $name, $pin );
283             return $width . 'x' . $height;
284             };
285              
286             post '/devices/:name/image/:pin/resolution/:width/:height' => sub {
287             my $name = params->{name};
288             my $pin = params->{pin};
289             my $width = params->{width};
290             my $height = params->{height};
291             $webio->img_set_width( $name, $pin, $width );
292             $webio->img_set_height( $name, $pin, $height );
293             return 1;
294             };
295              
296             get '/devices/:name/image/:pin/allowed-content-types' => sub {
297             my $name = params->{name};
298             my $pin = params->{pin};
299             my $types = $webio->img_allowed_content_types( $name, $pin );
300             return join( "\n", @$types );
301             };
302              
303             get '/devices/:name/image/:pin/stream/:mime1/:mime2' => sub {
304             my $name = params->{name};
305             my $pin = params->{pin};
306             my $mime1 = params->{mime1};
307             my $mime2 = params->{mime2};
308             my $mime = "$mime1/$mime2";
309             my $fh = $webio->img_stream( $name, $pin, $mime );
310              
311             local $/ = undef;
312             my $buffer = <$fh>;
313             close $fh;
314              
315             content_type $mime;
316             return $buffer;
317             };
318              
319             get '/devices/:name/sensor/temperature/c' => sub {
320             my $name = params->{name};
321             my $count = $webio->temp_celsius( $name );
322             return $count;
323             };
324              
325             get '/devices/:name/sensor/temperature/k' => sub {
326             my $name = params->{name};
327             my $count = $webio->temp_kelvins( $name );
328             return $count;
329             };
330              
331             get '/devices/:name/sensor/temperature/f' => sub {
332             my $name = params->{name};
333             my $count = $webio->temp_fahrenheit( $name );
334             return $count;
335             };
336              
337              
338             get '/GPIO/:pin/function' => sub {
339             my $pin = params->{pin};
340              
341             my $type = lc _get_io_type( $default_name, $pin );
342             return $type;
343             };
344              
345             post '/GPIO/:pin/function/:func' => sub {
346             my $pin = params->{pin};
347             my $func = uc params->{func};
348              
349             if( 'IN' eq $func ) {
350             $webio->set_as_input( $default_name, $pin );
351             }
352             elsif( 'OUT' eq $func ) {
353             $webio->set_as_output( $default_name, $pin );
354             }
355             else {
356             # TODO
357             }
358              
359             return '';
360             };
361              
362             get '/GPIO/:pin/value' => sub {
363             my $pin = params->{pin};
364             my $in = $webio->digital_input( $default_name, $pin );
365             return $in;
366             };
367              
368             post '/GPIO/:pin/value/:value' => sub {
369             my $pin = params->{pin};
370             my $value = params->{value};
371              
372             $webio->digital_output( $default_name, $pin, $value );
373              
374             return '';
375             };
376              
377             post '/GPIO/:pin/pulse' => sub {
378             my $pin = params->{pin};
379              
380             $webio->digital_output( $default_name, $pin, 1 );
381             sleep PULSE_TIME;
382             $webio->digital_output( $default_name, $pin, 0 );
383              
384             return '';
385             };
386              
387             post '/GPIO/:pin/sequence/:seq' => sub {
388             my $pin = params->{pin};
389             my $seq = params->{seq};
390             my ($duration, $bits) = split /,/, $seq, 2;
391             my @bits = split //, $bits;
392              
393             foreach my $value (@bits) {
394             my $duration_ms = $duration / 1000;
395              
396             $webio->digital_output( $default_name, $pin, $value );
397             sleep $duration_ms;
398             }
399              
400             return '';
401             };
402              
403              
404             get '/map' => sub {
405             return to_json( $webio->pin_desc( $default_name ) );
406             };
407              
408             get qr{\A / \* }x => sub {
409             return to_json( $webio->all_desc( $default_name ) );
410             };
411              
412              
413             get '/' => sub {
414             return 'Hello, world!';
415             };
416              
417             get '/app/*' => sub {
418             my $params = shift;
419             my ($file) = @{ params->{splat} };
420             my $path = File::Spec->catfile( $public_dir, 'app', $file );
421             send_file( $path,
422             system_path => 1,
423             );
424             };
425              
426              
427              
428             sub _int_to_array
429             {
430 1     1   20 my ($int, @index_list) = @_;
431             my @values = map {
432 1         2 ($int >> $_) & 1
  8         8  
433             } @index_list;
434 1         3 return @values;
435             }
436              
437             sub _get_io_type
438             {
439 12     12   13 my ($name, $pin) = @_;
440             # Ignore exceptions
441 12         18 my $type = eval { $webio->is_set_input( $name, $pin ) } ? 'IN'
442 12 50       13 : eval { $webio->is_set_output( $name, $pin ) } ? 'OUT'
  4 100       142  
443             : 'UNSET';
444 12 50       393 warn "Caught exception while getting IO type for pin '$pin': $@\n" if $@;
445 12         14 return $type;
446             }
447              
448              
449             1;
450             __END__