purescript-postgresql-client/purspgpp

#!/usr/bin/env perl6
use v6;
use NativeCall;

module libpq {
    constant LIBPQ = "libpq";

    sub PQconnectdb(Str --> Pointer[void]) is native(LIBPQ) {*}

    sub PQstatus(Pointer[void] --> int32) is native(LIBPQ) {*}
    sub PQerrorMessage(Pointer[void] --> Str) is native(LIBPQ) {*}
    sub PQresultStatus(Pointer[void] --> int32) is native(LIBPQ) {*}
    sub PQresultErrorMessage(Pointer[void] --> Str) is native(LIBPQ) {*}

    sub PQprepare(Pointer[void], Str, Str, int32, Pointer[void] --> Pointer[void]) is native(LIBPQ) {*}
    sub PQdescribePrepared(Pointer[void], Str --> Pointer[void]) is native(LIBPQ) {*}
    sub PQnparams(Pointer[void] --> int32) is native(LIBPQ) {*}
    sub PQparamtype(Pointer[void], int32 --> uint32) is native(LIBPQ) {*}
    sub PQnfields(Pointer[void] --> int32) is native(LIBPQ) {*}
    sub PQftype(Pointer[void], int32 --> uint32) is native(LIBPQ) {*}

    our class Description {
        has Int:D @.parameters;
        has Int:D @.fields;
    }

    our class Connection {
        has Pointer[void] $!handle;

        method new(Str:D $connection-string) {
            self.bless(:$connection-string);
        }

        submethod BUILD(Str:D :$connection-string) {
            my $handle = PQconnectdb($connection-string);
            die PQerrorMessage($handle) unless PQstatus($handle) == 0;
            $!handle = $handle;
        }

        method prepare(Str:D $name, Str:D $source) {
            my $result = PQprepare($!handle, $name, $source, 0, Nil);
            die PQerrorMessage($!handle) without $result;
            die PQresultErrorMessage($result) unless PQresultStatus($result) == 1;
        }

        method describe-prepared(Str:D $name) {
            my $result = PQdescribePrepared($!handle, $name);
            die PQerrorMessage($!handle) without $result;
            die PQresultErrorMessage($result) unless PQresultStatus($result) == 1;
            my @parameters = (^PQnparams($result)).map({PQparamtype($result, $_)});
            my @fields = (^PQnfields($result)).map({PQftype($result, $_)});
            Description.new(:@parameters, :@fields);
        }
    }
}

my Str:D %types{Int:D} =
    16 => 'Boolean',
    17 => 'ByteString',
    18 => 'Char',
    23 => 'Int',
    25 => 'String',
    701 => 'Number',
    2950 => 'UUID',
    2951 => 'List UUID',
;

sub process-module(libpq::Connection $conn, Str:D $segment --> Str:D) {
    S:g/'[query|' (.*?) '|]'/&process-query($conn, ~$0)/ given $segment;
}

multi sub process-query(libpq::Connection:D $conn, Str:D $source --> Str:D) {
    $conn.prepare: '', $source;
    my $description = $conn.describe-prepared('');
    sub convert-types(@oids) {
        die "unknown oid: $_" unless %types{$_}:exists for @oids;
        (|@oids.map({%types{$_}}), "Unit").join(" × ");
    };
    my $parameters = convert-types($description.parameters);
    my $fields = convert-types($description.fields);
    "(Query \"\"\"$source\"\"\" :: Query ($parameters) ($fields))";
}

multi sub process-query(libpq::Connection:U, Str:D $source --> Str:D) {
    "(Query \"\"\"$source\"\"\")";
}

multi sub MAIN(Str $connection-string, IO(Cool) $in-file, IO(Cool) $out-file = '-', Bool :$syntax-only where !*) {
    my $conn = libpq::Connection.new($connection-string);
    $out-file.spurt: process-module($conn, $in-file.slurp);
}

multi sub MAIN(IO(Cool) $in-file, IO(Cool) $out-file = '-', Bool :$syntax-only where *) {
    $out-file.spurt: process-module(libpq::Connection, $in-file.slurp);
}