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

}