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