diff -r aaa61e5b4526 -r 3d9a0d238469 synapse/check.server.pl
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/synapse/check.server.pl	Wed Aug 03 10:43:29 2022 +0200
@@ -0,0 +1,246 @@
+#!/usr/bin/perl
+#$Id: check.server.pl,v 1d715c5989e8 2022/08/03 08:42:01 grin $
+#
+# (cc)by_sa-4.0 / GPLv3+  peter 'grin' gervai  @grin:grin.hu
+#
+# hastily check a matrix server
+
+## requires:
+##  - libjson-perl
+##  - curl
+##  - fping
+##  - dnsutils (dig)
+
+## todo:
+##  - apart from complete rewriting?
+##  - check whether curl, fping, dig present
+##  - well, really, check _anything_. no real error handling as of now.
+
+# returns:
+#  1: error
+#  0: ok
+
+use warnings; use strict;
+
+# https://$d/.well-known/matrix/server
+# https://$d/.well-known/matrix/support
+
+use JSON;
+use Data::Dumper;
+
+# 1: print everything, verbosely, even if it's unparseable.
+# 0: less chat, bad results are fatal; use exit code
+my $VERBOSE=1;
+
+my $j = JSON->new->allow_nonref;
+
+my $d = $ARGV[0];
+if( !defined( $d ) ) {
+    print "Usage: $0 <matrix_domain>\nExample: $0 grin.hu\n";
+    exit 1;
+}
+
+my $data_source=0;
+# curl parameters for connection
+my $timeout="--connect-timeout 5";
+my $follow_redirs="--location --max-redirs 4";
+
+# collect well-known, infodata, nodeinfo, dns SRV
+my ($srv,$port) = &get_wk($d);
+&get_wk_infodata($d);
+&get_wk_nodeinfo2($d);
+my ($srv2,$port2) = &get_srv($d);
+
+if( $srv ) { 
+    # we have well-known data, lovely
+    $data_source=1;
+} elsif( $srv2 ) {
+    # we have SRV, it'll do
+    ($srv,$port) = ($srv2,$port2);
+    $data_source=2;
+} else {
+    # lazy admin mode
+    ($srv,$port) = ($d, 8448);
+    $data_source=3;
+}
+
+print "FINAL result is $srv:$port. Checking.\n";
+my $srv_full = "$srv:$port";
+
+# ping the server first
+print "Ping: ";
+my $res = `fping --retry=3 --timeout=500 $srv`; chomp $res;
+print "$res!\n";
+
+# get server version
+print "SrvVersion: ";
+
+my $cmd1;
+if( $data_source == 2 ) {
+    # SRV uses domain for SNI
+    $cmd1 = "-s $timeout $follow_redirs --connect-to $srv https://$d:$port/_matrix/federation/v1/version";
+} else {
+    # everyone else go for the hostname
+    $cmd1 = "-s $timeout $follow_redirs https://$srv_full/_matrix/federation/v1/version";
+    
+    if( $srv_full eq "" ) {
+        # shall not happen (and really, can't now)
+        &fail( "srv_full empty while data_source=$data_source");
+    } 
+}
+my $cmd  = "curl $cmd1";
+$res = qx($cmd);
+if( $res =~ /"server"/ ) {
+    # seems like valid data
+    my $data = $j->decode($res);
+    my $v = $$data{'server'};
+    
+    print $$v{name} . '/' . $$v{version}."!\n";
+
+} else {
+    # got something, but it's crap.
+    print "no parseable data\n";
+    if( !$VERBOSE ) {
+        &fail("no paresable data");
+    }
+    
+    print "here's the debug: ";
+    $cmd="curl $timeout --verbose $cmd1";
+    print "$cmd\n";
+    system $cmd;
+    &fail("no parseable data");
+}
+
+# sucess
+exit 0;
+
+
+##########
+
+
+# get well-known in a naïve way
+sub get_wk {
+    my ($d) = @_;
+    
+    ## try well-known matrix/server (simplistic parser; spec)
+    print "WellKnown: ";
+    $cmd = "curl $timeout $follow_redirs -s https://$d/.well-known/matrix/server";
+    $res = qx($cmd);
+
+    if( $res=~/m.server/ ) {
+        my $data = $j->decode($res);
+        my $srv_full = $$data{'m.server'};
+        if( $srv_full =~ /^(.+):(.+)$/ ) {
+            # we have proper form
+            ($srv,$port) = ($1,$2);
+            } else {
+                # missing port or crap result
+                print Dumper($data);
+                print "$srv_full don't contain port!!\n";
+                print "FAKING port 8448\n";
+                $port=8448;
+            }
+        print "$srv on port $port!\n";
+    } else {
+        # I can't even...
+        print " (unparseable response from $cmd )\n";
+        print "$res\n" if $VERBOSE;;
+        print "No well-known 'm.server'.\n";
+        return;
+    }
+    return ($srv,$port);
+}
+
+
+## get well-known/matrix/support info (infodata; MSC1929)
+sub get_wk_infodata {
+    my ($d) = @_;
+
+    print "# Checking https://$d/.well-known/matrix/support\n";    
+    print "WellKnown(MSC1929): ";
+    $cmd = "curl $timeout $follow_redirs -s https://$d/.well-known/matrix/support";
+    $res = qx($cmd);
+
+    if( $res=~/admins/ ) {
+        my $data = $j->decode($res);
+        my $admins = $$data{'admins'};
+        
+        for my $entry (@$admins) {
+            print $$entry{'role'}.":";
+            delete $$entry{'role'};
+            for my $k (sort keys %$entry) {
+                print "$k=" . $$entry{$k}." ";
+            }
+            print "; ";
+        }
+        print "\n";
+    } else {
+        print "nope\n";
+    }
+}
+
+
+# try get nodeinfo2, https://github.com/jaywink/nodeinfo2
+sub get_wk_nodeinfo2 {
+    my ($d) = @_;
+
+    print "# checking https://$d/.well-known/x-nodeinfo2\n";    
+    print "nodeinfo2: ";
+    $cmd = "curl $timeout $follow_redirs -s https://$d/.well-known/x-nodeinfo2";
+    $res = qx($cmd);
+    if( $res =~ /version/ ) {
+        my $data = $j->decode($res);
+        if( $$data{'version'} ne '1.0' ) {
+            print " (unknown version " . $$data{'version'} . ") ";
+        }
+
+        if( $$data{'openRegistrations'} ) {
+            print "OPENREG! ";
+        }
+
+        print "proto: " . join(',', @{$$data{'protocols'}}) . " ";
+
+        print "srv: ";
+        for my $field ( qw( baseUrl name software ) ) {
+            print "$field=" . $$data{'server'}{$field} . " ";
+        }
+
+        print "org: ";
+        for my $field ( qw( name contact admin ) ) {
+            print "$field=" . $$data{'organization'}{$field} . " ";
+        }
+    } else {
+        print "none";
+    }
+    print "\n";
+}
+
+# DNS SRV in an extremely lazy way
+sub get_srv {
+    my ($d) = @_;
+        
+    my ($srv,$port);
+
+    ## try srv (simplistic as well)
+    print "SRV (_matrix._tcp.$d): ";
+    $res = `dig _matrix._tcp.$d srv +short`;
+    print "$res";
+    if( $res =~ /^(\d+)\s+(\d+)\s+(\d+)\s+(\S+)\.$/ ) {
+        # looks good
+        my ($pri1,$pri2);
+        ($pri1, $pri2, $port, $srv) = ($1,$2,$3,$4);
+    } else {
+        print "No SRV found.\n";
+        return;
+    }
+    return ($srv,$port);
+}
+    
+
+# guess what?
+sub fail {
+    my ($msg) = @_;
+    print "FAIL: $msg\n";
+    exit(1);
+}
+