1 #!/usr/bin/perl

     2 #$Id: check.server.pl,v 1d715c5989e8 2022/08/03 08:42:01 grin $

     3 #

     4 # (cc)by_sa-4.0 / GPLv3+  peter 'grin' gervai  @grin:grin.hu

     5 #

     6 # hastily check a matrix server

     7 

     8 ## requires:

     9 ##  - libjson-perl

    10 ##  - curl

    11 ##  - fping

    12 ##  - dnsutils (dig)

    13 

    14 ## todo:

    15 ##  - apart from complete rewriting?

    16 ##  - check whether curl, fping, dig present

    17 ##  - well, really, check _anything_. no real error handling as of now.

    18 

    19 # returns:

    20 #  1: error

    21 #  0: ok

    22 

    23 use warnings; use strict;

    24 

    25 # https://$d/.well-known/matrix/server

    26 # https://$d/.well-known/matrix/support

    27 

    28 use JSON;

    29 use Data::Dumper;

    30 

    31 # 1: print everything, verbosely, even if it's unparseable.

    32 # 0: less chat, bad results are fatal; use exit code

    33 my $VERBOSE=1;

    34 

    35 my $j = JSON->new->allow_nonref;

    36 

    37 my $d = $ARGV[0];

    38 if( !defined( $d ) ) {

    39     print "Usage: $0 <matrix_domain>\nExample: $0 grin.hu\n";

    40     exit 1;

    41 }

    42 

    43 my $data_source=0;

    44 # curl parameters for connection

    45 my $timeout="--connect-timeout 5";

    46 my $follow_redirs="--location --max-redirs 4";

    47 

    48 # collect well-known, infodata, nodeinfo, dns SRV

    49 my ($srv,$port) = &get_wk($d);

    50 &get_wk_infodata($d);

    51 &get_wk_nodeinfo2($d);

    52 my ($srv2,$port2) = &get_srv($d);

    53 

    54 if( $srv ) { 

    55     # we have well-known data, lovely

    56     $data_source=1;

    57 } elsif( $srv2 ) {

    58     # we have SRV, it'll do

    59     ($srv,$port) = ($srv2,$port2);

    60     $data_source=2;

    61 } else {

    62     # lazy admin mode

    63     ($srv,$port) = ($d, 8448);

    64     $data_source=3;

    65 }

    66 

    67 print "FINAL result is $srv:$port. Checking.\n";

    68 my $srv_full = "$srv:$port";

    69 

    70 # ping the server first

    71 print "Ping: ";

    72 my $res = `fping --retry=3 --timeout=500 $srv`; chomp $res;

    73 print "$res!\n";

    74 

    75 # get server version

    76 print "SrvVersion: ";

    77 

    78 my $cmd1;

    79 if( $data_source == 2 ) {

    80     # SRV uses domain for SNI

    81     $cmd1 = "-s $timeout $follow_redirs --connect-to $srv https://$d:$port/_matrix/federation/v1/version";

    82 } else {

    83     # everyone else go for the hostname

    84     $cmd1 = "-s $timeout $follow_redirs https://$srv_full/_matrix/federation/v1/version";

    85     

    86     if( $srv_full eq "" ) {

    87         # shall not happen (and really, can't now)

    88         &fail( "srv_full empty while data_source=$data_source");

    89     } 

    90 }

    91 my $cmd  = "curl $cmd1";

    92 $res = qx($cmd);

    93 if( $res =~ /"server"/ ) {

    94     # seems like valid data

    95     my $data = $j->decode($res);

    96     my $v = $$data{'server'};

    97     

    98     print $$v{name} . '/' . $$v{version}."!\n";

    99 

   100 } else {

   101     # got something, but it's crap.

   102     print "no parseable data\n";

   103     if( !$VERBOSE ) {

   104         &fail("no paresable data");

   105     }

   106     

   107     print "here's the debug: ";

   108     $cmd="curl $timeout --verbose $cmd1";

   109     print "$cmd\n";

   110     system $cmd;

   111     &fail("no parseable data");

   112 }

   113 

   114 # sucess

   115 exit 0;

   116 

   117 

   118 ##########

   119 

   120 

   121 # get well-known in a naïve way

   122 sub get_wk {

   123     my ($d) = @_;

   124     

   125     ## try well-known matrix/server (simplistic parser; spec)

   126     print "WellKnown: ";

   127     $cmd = "curl $timeout $follow_redirs -s https://$d/.well-known/matrix/server";

   128     $res = qx($cmd);

   129 

   130     if( $res=~/m.server/ ) {

   131         my $data = $j->decode($res);

   132         my $srv_full = $$data{'m.server'};

   133         if( $srv_full =~ /^(.+):(.+)$/ ) {

   134             # we have proper form

   135             ($srv,$port) = ($1,$2);

   136             } else {

   137                 # missing port or crap result

   138                 print Dumper($data);

   139                 print "$srv_full don't contain port!!\n";

   140                 print "FAKING port 8448\n";

   141                 $port=8448;

   142             }

   143         print "$srv on port $port!\n";

   144     } else {

   145         # I can't even...

   146         print " (unparseable response from $cmd )\n";

   147         print "$res\n" if $VERBOSE;;

   148         print "No well-known 'm.server'.\n";

   149         return;

   150     }

   151     return ($srv,$port);

   152 }

   153 

   154 

   155 ## get well-known/matrix/support info (infodata; MSC1929)

   156 sub get_wk_infodata {

   157     my ($d) = @_;

   158 

   159     print "# Checking https://$d/.well-known/matrix/support\n";    

   160     print "WellKnown(MSC1929): ";

   161     $cmd = "curl $timeout $follow_redirs -s https://$d/.well-known/matrix/support";

   162     $res = qx($cmd);

   163 

   164     if( $res=~/admins/ ) {

   165         my $data = $j->decode($res);

   166         my $admins = $$data{'admins'};

   167         

   168         for my $entry (@$admins) {

   169             print $$entry{'role'}.":";

   170             delete $$entry{'role'};

   171             for my $k (sort keys %$entry) {

   172                 print "$k=" . $$entry{$k}." ";

   173             }

   174             print "; ";

   175         }

   176         print "\n";

   177     } else {

   178         print "nope\n";

   179     }

   180 }

   181 

   182 

   183 # try get nodeinfo2, https://github.com/jaywink/nodeinfo2

   184 sub get_wk_nodeinfo2 {

   185     my ($d) = @_;

   186 

   187     print "# checking https://$d/.well-known/x-nodeinfo2\n";    

   188     print "nodeinfo2: ";

   189     $cmd = "curl $timeout $follow_redirs -s https://$d/.well-known/x-nodeinfo2";

   190     $res = qx($cmd);

   191     if( $res =~ /version/ ) {

   192         my $data = $j->decode($res);

   193         if( $$data{'version'} ne '1.0' ) {

   194             print " (unknown version " . $$data{'version'} . ") ";

   195         }

   196 

   197         if( $$data{'openRegistrations'} ) {

   198             print "OPENREG! ";

   199         }

   200 

   201         print "proto: " . join(',', @{$$data{'protocols'}}) . " ";

   202 

   203         print "srv: ";

   204         for my $field ( qw( baseUrl name software ) ) {

   205             print "$field=" . $$data{'server'}{$field} . " ";

   206         }

   207 

   208         print "org: ";

   209         for my $field ( qw( name contact admin ) ) {

   210             print "$field=" . $$data{'organization'}{$field} . " ";

   211         }

   212     } else {

   213         print "none";

   214     }

   215     print "\n";

   216 }

   217 

   218 # DNS SRV in an extremely lazy way

   219 sub get_srv {

   220     my ($d) = @_;

   221         

   222     my ($srv,$port);

   223 

   224     ## try srv (simplistic as well)

   225     print "SRV (_matrix._tcp.$d): ";

   226     $res = `dig _matrix._tcp.$d srv +short`;

   227     print "$res";

   228     if( $res =~ /^(\d+)\s+(\d+)\s+(\d+)\s+(\S+)\.$/ ) {

   229         # looks good

   230         my ($pri1,$pri2);

   231         ($pri1, $pri2, $port, $srv) = ($1,$2,$3,$4);

   232     } else {

   233         print "No SRV found.\n";

   234         return;

   235     }

   236     return ($srv,$port);

   237 }

   238     

   239 

   240 # guess what?

   241 sub fail {

   242     my ($msg) = @_;

   243     print "FAIL: $msg\n";

   244     exit(1);

   245 }

   246