From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

PEVANS / Net-Prometheus-0.12 / lib / Net / Prometheus / _FutureIO.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

              
#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2022 -- leonerd@leonerd.org.uk
package Net::Prometheus::_FutureIO;
use strict;
use warnings;
use Future::IO 0.11;
use Future::Utils qw( repeat );
# TODO: Consider if we want to use Future::AsyncAwait to make this all a lot neater
my %running_clients;
sub start
{
   my $pkg = shift;
   my ( $prometheus, $listensock ) = @_;
   Future::IO->HAVE_MULTIPLE_FILEHANDLES or
      die "Net::Prometheus::_FutureIO requires a Future::IO implementation that supports multiple filehandles\n";
   return ( repeat {
      return Future::IO->accept( $listensock )->then( sub {
         my ( $clientsock ) = @_;
         my $fileno = $clientsock->fileno;
         my $f = $pkg->serve( $prometheus, $clientsock );
         $running_clients{$fileno} = $f;
         $f->on_done( sub {
            delete $running_clients{$fileno};
         });
         $f->on_fail( sub {
            warn "Net::Prometheus builtin HTTP server failed for [$fileno]: $_[0]";
            delete $running_clients{$fileno};
         });
         return Future->done;
      });
   } while => sub { !$_[0]->failure } )->on_fail( sub {
      warn "Net::Prometheus builtin HTTP server crashed: $_[0]";
   });
}
my %HTTP_CODES = (
   200 => "OK",
   400 => "Bad Request",
   405 => "Method Not Allowed",
);
sub serve
{
   my $pkg = shift;
   my ( $prometheus, $fh ) = @_;
   my $buf = "";
   my $f = repeat {
      Future::IO->sysread( $fh, 8192 )->then( sub {
         $buf .= $_[0];
         Future->done;
      } );
   } until => sub { $_[0]->failure or $buf =~ m/\x0d\x0a\x0d\x0a/ };
   # Parse request and generate a response code
   $f = $f->then( sub {
      my ( $req ) = $buf =~ m/^(.*\x0d\x0a\x0d\x0a)/s;
      ( my ( $firstline, $headers ) = split m/\x0d\x0a/, $req, 2 ) == 2 or
         return Future->done( 400 );
      my ( $method, $path, $proto ) = split m/\s+/, $firstline;
      return Future->done( 400 ) unless $proto =~ m(^HTTP/1\.[01]$);
      return Future->done( 200 ) if $method eq "GET";
      return Future->done( 200, 1 ) if $method eq "HEAD";
      return Future->done( 405 );
   });
   # Render an actual response and send it
   $f = $f->then( sub {
      my ( $code, $is_head ) = @_;
      my $body = "";
      $body .= $prometheus->render if $code == 200;
      my $response = "HTTP/1.0 $code $HTTP_CODES{$code}\n";
      $response .= "Content-Type: text/plain\n";
      $response .= sprintf "Content-Length: %d\n", length $body;
      $response .= "\n";
      $response =~ s/\n/\x0d\x0a/g;
      $response .= $body unless $is_head;
      return Future::IO->syswrite( $fh, $response );
   });
   return $f;
}
0x55AA;