#!/usr/bin/perl -w
#
# Copyright (c) 2022 Adrian Schroeter, SUSE LLC
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################
#
# OBS Git LFS provider
#
# This service answers git LFS requests and let OBS deliver the files
# based on a static database.
#
# This is only supposed to be used for converted sources from classic
# OBS source repositories. This is not supposed to be used for sources
# which are supposed to be actively maintained in git directly.
#

BEGIN {
  my ($wd) = $0 =~ m-(.*)/-;
  $wd ||= '.';
  unshift @INC, "$wd";
}

use Data::Dumper;
use JSON::XS ();

use BSServer;
use BSDispatch;
use BSSQLite;
use DBI qw(:sql_types);
use strict;

my $port = 9999;
my $proto = 'http';

my $base_url = "https://api.opensuse.org/public";
my $base_url_file = "/etc/obs-git-lfs/base_url";
my $db_file = "/var/lib/obs-git-lfs/database";
my $secret_file = "/etc/obs-git-lfs/secret";

my $secret;

sub make_url {
  my ($url, @args) = @_;
  if ($url =~ /^(https?:\/\/[^\/]*\/)(.*)$/s) {
    $url = $1;
    $url .= BSHTTP::urlencode($2);
  } else {
    $url .= BSHTTP::urlencode($url);
  }
  $url .= (($url =~ /\?/) ? '&' : '?') . BSHTTP::queryencode(@args) if @args;
  return $url;
}

sub check_oid {
  my ($cgi, $oid, $size) = @_;

  my $h = BSSQLite::connectdb($db_file);
  my $resp = {oid => $oid, size => int($size)};
  my @ary = BSSQLite::selectrow($h, "SELECT project,package,filename,rev FROM lfs_oids WHERE sha256 = ? AND size = ? LIMIT 1", lc($oid), $size);
  if (@ary != 4) {
    BSServer::reply("No such OID\n", "Status: 404 not_found");
  } else {
    my ($projid, $packid, $filename, $md5) = @ary;
    my $url = make_url("$base_url/source/$projid/$packid/$filename", "rev=$md5");
    return ($url, 'Content-Type: text/plain');
  }
}

sub add_oid {
  die("need OID data as content\n") unless BSServer::have_content();
  my $json = BSServer::read_data(10000) || die "Not enough data";
  my $oid_data = JSON::XS::decode_json($json) || die "Not in json format";
  die "Expected a hash" unless ref($oid_data) eq 'HASH';
  die "Invalid secret" unless ($oid_data->{secret} || '') eq $secret;
  my $h = BSSQLite::connectdb($db_file) || die "Can't open database";
  for my $arg (qw(project package filename rev sha256 size)) {
    die "Missing argument $arg" unless defined $oid_data->{$arg};
  }
  BSSQLite::dbdo_bind($h, "INSERT OR IGNORE INTO lfs_oids(project,package,filename,rev,sha256,size) VALUES(?,?,?,?,?,?);",
    [$oid_data->{project}, SQL_VARCHAR],
    [$oid_data->{package}, SQL_VARCHAR],
    [$oid_data->{filename}, SQL_VARCHAR],
    [$oid_data->{rev}, SQL_VARCHAR],
    [$oid_data->{sha256}, SQL_VARCHAR],
    [$oid_data->{size}, SQL_INTEGER]);
}

sub getgitlfs {
  die("need batch data as content\n") unless BSServer::have_content();
  my $batch_json = BSServer::read_data(10000000);
  my $batch = JSON::XS::decode_json($batch_json);

  # print $batch_json;
  # print Dumper($batch);

  die("not a supported operation: $batch->{'operation'}\n") unless $batch->{'operation'} eq 'download' || $batch->{'operation'} eq 'upload';
  die("409 not using sha256 as hash algo\n") if defined($batch->{'hash_algo'}) && $batch->{'hash_algo'} ne 'sha256';

  my $h = BSSQLite::connectdb($db_file);
  my @resobj;
  for my $obj (@{$batch->{'objects'}}) {
    my $oid = $obj->{'oid'};
    my $size = $obj->{'size'};
    my $r = {oid => $oid, size => int($size)};
    my @ary = BSSQLite::selectrow($h, "SELECT project,package,filename,rev FROM lfs_oids WHERE sha256 = ? AND size = ? ORDER BY Length(project)", lc($oid), $size);
    #  print Dumper(@ary);
    if (@ary != 4) {
      print "$oid/$size: not found\n";
      if ($batch->{'operation'} eq 'upload') {
        $r->{'error'} = {code => 403, message => 'LFS Upload is not supported by this read only server, check your .lfsconfig file'};
      } else {
        $r->{'error'} = {code => 404, message => 'Object does not exist'};
      }
    } elsif ($batch->{'operation'} eq 'download') {
      my ($projid, $packid, $filename, $md5) = @ary;
      my $url = make_url("$base_url/source/$projid/$packid/$filename", "rev=$md5");
      print "$oid/$size: $url\n";
      $r->{'authenticated'} = JSON::XS::true;
      $r->{'actions'} = {download => {href => $url}};
    }
    push @resobj, $r;
  }
  my $resp = {
    transfer => 'basic',
    hash_algo => 'sha256',
    objects => \@resobj,
  };
  #  print Dumper(JSON::XS::encode_json($resp));
  return (JSON::XS::encode_json($resp), 'Content-Type: application/json');
}

sub dummylock {
  die("404 read-only server\n");
}

sub hello {
  return ("{\"message\": \"OBS git LFS Server\"}\n", 'Content-Type: application/json');
}

sub errorreply {
  my ($err, $code, $tag, @hdrs) = @_;
  $err = JSON::XS::encode_json({'message' => $tag});
  BSServer::reply("$err\n", "Status: $code $tag", 'Content-Type: application/json', @hdrs);
}

sub dispatch {
  my ($conf, $req) = @_;
  return BSDispatch::dispatch($conf, $req);
}

# define server
my $dispatches = [
  '/' => \&hello,
  'GET:/check/$oid/$size' => \&check_oid,
  'POST:/gitlfs/objects/batch' => \&getgitlfs,
  'POST:/gitlfs/locks/verify' => \&dummylock,
  'POST:/register' => \&add_oid,
];

sub verify_oid {
}

sub verify_num {
}

my $conf = {
  'port' => $port,
  'proto' => $proto,
  'dispatch' => \&dispatch,
  'dispatches' => $dispatches,
  'errorreply' => \&errorreply,
  'setkeepalive' => 1,
  'maxchild' => 20,
  'verifiers' => {oid => \&verify_oid, size => \&verify_num},
};

if (-e $base_url_file) {
  if (open(my $fh, "<", $base_url_file)) {
    $base_url = <$fh>;
    chomp $base_url;
  }
}
if (open(my $fh, "<", $secret_file)) {
  $secret = <$fh>;
  chomp $secret;
}

BSDispatch::compile($conf);
BSServer::serveropen($conf->{'port'});
BSServer::server($conf);
