#!/usr/bin/env bash
#
# Verify per-R-minor index routing for cran.rpkgs.com across every published
# <arch>/<os> slot.
#
# The edge router (edge/rpkgs-router.ts) rewrites PACKAGES* requests to
# `contrib/<x.y>/` when the slot is listed in UNION_SLOTS and the client's
# User-Agent carries an R minor. Two properties have to hold before a slot may
# be added to UNION_SLOTS:
#
#   1. the per-minor index is a UNION of the per-minor and flat slots, so
#      routing to it hides nothing the flat index carries; and
#   2. every R minor a client might report resolves to an index that exists,
#      because contribPath() does not check existence and has no fallback.
#
# Modes:
#   (default)  Resolve routing decisions without depending on UNION_SLOTS being
#              set. Safe to run before enabling: it reads the per-minor indexes
#              directly and reproduces the router's target path.
#   --live     Additionally drive the real CDN with R User-Agents and assert the
#              bytes served match the expected index. Only meaningful once the
#              slot is in UNION_SLOTS.
#
# Usage:
#   scripts/verify-r-minor-routing.sh
#   scripts/verify-r-minor-routing.sh --live
#   MINORS="4.4 4.5" SAMPLE=10 scripts/verify-r-minor-routing.sh
#
# Exits non-zero if any check fails.

set -uo pipefail

BASE=${BASE:-https://cran.rpkgs.com}
ARCHES=${ARCHES:-"amd64 arm64"}
DISTROS=${DISTROS:-"resolute noble jammy rhel8 rhel9 rhel10 alpine323 alpine324"}
# The supported window: the current R minor plus the two previous, matching
# build-env-images' R_VERSION_LATEST/PREV1/PREV2 and cdn.tf's
# local.rpkgs_supported_minors. Each of these must have a published index.
MINORS=${MINORS:-"4.4 4.5 4.6"}
# Minors we deliberately do not serve. These must have NO published index and,
# once routing is live, must be sent to CRAN for sources rather than 404ing or
# being handed binaries built under another minor.
EXCLUDED_MINORS=${EXCLUDED_MINORS:-"4.3"}
# How many Path: targets to HEAD-check per slot/minor. 0 disables.
SAMPLE=${SAMPLE:-5}
# Largest package-count shortfall a non-primary minor may have against the best
# minor on the same slot before coverage counts as uneven. A slot built under
# one R minor carries fewer per-minor binaries for the others; until that gap
# closes, "full coverage for ABI-sensitive packages" is not a claim we can make.
PARITY_TOLERANCE=${PARITY_TOLERANCE:-25}
LIVE=0

for arg in "$@"; do
  case "$arg" in
    --live) LIVE=1 ;;
    -h | --help)
      sed -n '2,32p' "$0"
      exit 0
      ;;
    *)
      echo "unknown argument: $arg" >&2
      exit 2
      ;;
  esac
done

WORK=$(mktemp -d)
trap 'rm -rf "$WORK"' EXIT

PASS=0
FAIL=0
FAILURES=""

ok() {
  PASS=$((PASS + 1))
  printf '  ok    %s\n' "$1"
}

bad() {
  FAIL=$((FAIL + 1))
  FAILURES="${FAILURES}\n  - $1"
  printf '  FAIL  %s\n' "$1"
}

# Fetch a URL into a file, echoing the HTTP status. Cached per URL.
fetch() {
  local url=$1 dest=$2 ua=${3:-}
  if [ -s "$dest" ]; then
    cat "$dest.status"
    return 0
  fi
  local status
  if [ -n "$ua" ]; then
    status=$(curl -sS -A "$ua" -o "$dest" -w '%{http_code}' --max-time 120 "$url" 2>/dev/null)
  else
    status=$(curl -sS -o "$dest" -w '%{http_code}' --max-time 120 "$url" 2>/dev/null)
  fi
  echo "$status" > "$dest.status"
  echo "$status"
}

head_status() {
  curl -sS -o /dev/null -w '%{http_code}' -I --max-time 60 "$1" 2>/dev/null
}

# Package names from a gzipped PACKAGES index, sorted.
pkg_names() {
  gunzip -c "$1" 2>/dev/null | awk '/^Package:/ {print $2}' | sort -u
}

# "<Package> <Path>" pairs for entries that carry a Path: field.
path_entries() {
  gunzip -c "$1" 2>/dev/null | awk '
    /^Package:/ { pkg = $2; ver = ""; path = "" }
    /^Version:/ { ver = $2 }
    /^Path:/    { path = $2 }
    /^$/        { if (pkg != "" && path != "") print pkg, ver, path; pkg = "" }
    END         { if (pkg != "" && path != "") print pkg, ver, path }
  '
}

# An R User-Agent of the shape R actually sends.
r_user_agent() {
  printf 'R/%s.0 (Ubuntu 24.04; codename=noble) (x86_64-pc-linux-gnu x86_64 linux-gnu)' "$1"
}

echo "verify-r-minor-routing: $BASE"
echo "  slots:  $(echo "$ARCHES" | wc -w) arch x $(echo "$DISTROS" | wc -w) os"
echo "  minors: $MINORS  (excluded: $EXCLUDED_MINORS)"
echo "  live:   $LIVE"
echo

for arch in $ARCHES; do
  for distro in $DISTROS; do
    slot="$arch/$distro"
    echo "$slot"

    flat_url="$BASE/$slot/latest/src/contrib/PACKAGES.gz"
    flat_file="$WORK/${arch}-${distro}-flat.gz"
    flat_status=$(fetch "$flat_url" "$flat_file")

    if [ "$flat_status" != "200" ]; then
      bad "$slot flat index unreachable (HTTP $flat_status)"
      continue
    fi

    pkg_names "$flat_file" > "$flat_file.names"
    flat_count=$(wc -l < "$flat_file.names")
    if [ "$flat_count" -lt 1000 ]; then
      bad "$slot flat index has only $flat_count packages"
      continue
    fi
    ok "$slot flat index: $flat_count packages"

    for minor in $MINORS; do
      minor_url="$BASE/$slot/latest/src/contrib/$minor/PACKAGES.gz"
      minor_file="$WORK/${arch}-${distro}-${minor}.gz"
      minor_status=$(fetch "$minor_url" "$minor_file")

      # A minor the router would route to must exist, or clients on that R
      # version get a 404 and see no packages at all.
      if [ "$minor_status" != "200" ]; then
        bad "$slot R $minor index missing (HTTP $minor_status) - routing would 404 for R $minor clients"
        continue
      fi

      pkg_names "$minor_file" > "$minor_file.names"
      minor_count=$(wc -l < "$minor_file.names")

      # Union property: nothing the flat index carries may be missing here.
      missing=$(comm -23 "$flat_file.names" "$minor_file.names" | head -5)
      missing_count=$(comm -23 "$flat_file.names" "$minor_file.names" | wc -l)
      if [ "$missing_count" -ne 0 ]; then
        bad "$slot R $minor index is not a union: $missing_count flat packages absent (e.g. $(echo "$missing" | tr '\n' ' '))"
      else
        ok "$slot R $minor index: $minor_count packages, union holds"
      fi

      # Path: entries steer to per-minor binaries; they must resolve.
      if [ "$SAMPLE" -gt 0 ]; then
        path_entries "$minor_file" > "$minor_file.paths"
        total_paths=$(wc -l < "$minor_file.paths")
        broken=0
        checked=0
        while read -r pkg ver path; do
          [ -z "${pkg:-}" ] && continue
          tarball="$BASE/$slot/latest/src/contrib/$path/${pkg}_${ver}.tar.gz"
          status=$(head_status "$tarball")
          checked=$((checked + 1))
          if [ "$status" != "200" ]; then
            broken=$((broken + 1))
            [ "$broken" -le 2 ] && printf '        broken target: %s (HTTP %s)\n' "$tarball" "$status"
          fi
        done < <(shuf -n "$SAMPLE" "$minor_file.paths" 2>/dev/null || head -n "$SAMPLE" "$minor_file.paths")

        if [ "$broken" -ne 0 ]; then
          bad "$slot R $minor: $broken/$checked sampled Path: targets do not resolve (of $total_paths total)"
        elif [ "$checked" -gt 0 ]; then
          ok "$slot R $minor: $checked/$checked sampled Path: targets resolve (of $total_paths total)"
        fi
      fi

      # Live routing: what a real R client on this minor actually receives.
      if [ "$LIVE" -eq 1 ]; then
        ua=$(r_user_agent "$minor")
        live_file="$WORK/${arch}-${distro}-${minor}-live.gz"
        live_status=$(fetch "$flat_url" "$live_file" "$ua")
        if [ "$live_status" != "200" ]; then
          bad "$slot R $minor live request failed (HTTP $live_status)"
        elif cmp -s "$live_file" "$minor_file"; then
          ok "$slot R $minor live request served the per-minor index"
        elif cmp -s "$live_file" "$flat_file"; then
          bad "$slot R $minor live request served the FLAT index - slot not in UNION_SLOTS?"
        else
          bad "$slot R $minor live request served neither the per-minor nor the flat index"
        fi
      fi
    done

    # Coverage parity across minors. The union property only guarantees no
    # client loses packages relative to the flat index; it says nothing about a
    # 4.4 client seeing fewer packages than a 4.5 client on the same slot.
    best=0
    for minor in $MINORS; do
      f="$WORK/${arch}-${distro}-${minor}.gz.names"
      [ -s "$f" ] || continue
      c=$(wc -l < "$f")
      [ "$c" -gt "$best" ] && best=$c
    done
    if [ "$best" -gt 0 ]; then
      uneven=""
      for minor in $MINORS; do
        f="$WORK/${arch}-${distro}-${minor}.gz.names"
        [ -s "$f" ] || continue
        c=$(wc -l < "$f")
        gap=$((best - c))
        [ "$gap" -gt "$PARITY_TOLERANCE" ] && uneven="$uneven R$minor:-$gap"
      done
      if [ -n "$uneven" ]; then
        bad "$slot coverage uneven across minors (vs best $best):$uneven"
      else
        ok "$slot coverage parity across minors (best $best, all within $PARITY_TOLERANCE)"
      fi
    fi

    # Excluded minors: no published index, and under --live a redirect to CRAN.
    for minor in $EXCLUDED_MINORS; do
      ex_url="$BASE/$slot/latest/src/contrib/$minor/PACKAGES.gz"
      ex_status=$(curl -sS -o /dev/null -w '%{http_code}' --max-time 60 "$ex_url" 2>/dev/null)
      if [ "$ex_status" = "200" ]; then
        bad "$slot R $minor is excluded but an index is published - the two lists disagree"
      else
        ok "$slot R $minor correctly has no published index"
      fi

      if [ "$LIVE" -eq 1 ]; then
        loc=$(curl -sS -o /dev/null -w '%{redirect_url}' -A "$(r_user_agent "$minor")" \
          --max-time 60 "$flat_url" 2>/dev/null)
        case "$loc" in
          https://cran.r-project.org/*)
            ok "$slot R $minor is sent to CRAN ($loc)"
            ;;
          "")
            bad "$slot R $minor was served directly instead of being sent to CRAN"
            ;;
          *)
            bad "$slot R $minor redirected somewhere unexpected: $loc"
            ;;
        esac
      fi
    done

    # A client whose User-Agent carries no R version must keep getting the flat
    # index, never a per-minor one.
    if [ "$LIVE" -eq 1 ]; then
      plain_file="$WORK/${arch}-${distro}-plain.gz"
      plain_status=$(fetch "$flat_url" "$plain_file" "curl/8.0.0")
      if [ "$plain_status" != "200" ]; then
        bad "$slot non-R User-Agent request failed (HTTP $plain_status)"
      elif cmp -s "$plain_file" "$flat_file"; then
        ok "$slot non-R User-Agent still served the flat index"
      else
        bad "$slot non-R User-Agent was routed away from the flat index"
      fi

      # Tarball requests must never be rewritten into a per-minor directory:
      # flat-slot packages do not live there.
      sample_pkg=$(gunzip -c "$flat_file" | awk '/^Package:/ {p=$2} /^Version:/ {print p, $2; exit}')
      if [ -n "$sample_pkg" ]; then
        # shellcheck disable=SC2086 # deliberate split into $1 (package) and $2 (version)
        set -- $sample_pkg
        tb="$BASE/$slot/latest/src/contrib/${1}_${2}.tar.gz"
        tb_status=$(curl -sS -o /dev/null -w '%{http_code}' -A "$(r_user_agent 4.5)" --max-time 60 "$tb" 2>/dev/null)
        if [ "$tb_status" = "200" ]; then
          ok "$slot tarball request under an R User-Agent still resolves"
        else
          bad "$slot tarball ${1}_${2}.tar.gz broke under an R User-Agent (HTTP $tb_status)"
        fi
      fi
    fi
  done
done

echo
echo "passed: $PASS   failed: $FAIL"
if [ "$FAIL" -ne 0 ]; then
  printf 'failures:%b\n' "$FAILURES"
  exit 1
fi