--- /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);
+}
+