(in-package #:lispsearch)

;;;; Tier-2 enrichment: versions (ocicl), .asd metadata + README (artifact).
;;;; All shelling-out uses the RAW registry_name and an explicit *registry*
;;;; (see M0 spike, lispsearch-plan.md §2). Each system is best-effort: failures
;;;; log and leave the row enriched=0 for a later retry.

(defparameter +readme-max-chars+ 200000
  "Cap stored README size to keep the FTS index sane.")

(defun system-versions (registry-name)
  "Run `ocicl -r *registry* list <registry-name>`. Returns (values tags latest)
where LATEST is the newest dated version (the first tag that isn't \"latest\").
Empty/not-found yields (values NIL NIL)."
  (let ((out (ignore-errors
               (uiop:run-program (list "ocicl" "-r" *registry* "list" registry-name)
                                 :output :string :error-output nil
                                 :ignore-error-status t))))
    (if (and out (plusp (length out)))
        (let ((tags (rest (split-lines out))))   ; drop the "<name> (...):" header
          (values tags (find-if (lambda (tag) (not (string= tag "latest"))) tags)))
        (values nil nil))))

(defun fetch-artifact (registry-name dir)
  "oras pull <*registry*>/<registry-name>:latest into DIR and extract the tarball.
Returns the extracted <name>-<version>/ directory pathname, or NIL on failure."
  (let ((ref (format nil "~A/~A:latest" *registry* registry-name)))
    (when (zerop (nth-value 2
                   (uiop:run-program (list "oras" "pull" ref "-o" (namestring dir))
                                     :output nil :error-output nil
                                     :ignore-error-status t)))
      (let ((tarball (first (directory (merge-pathnames "*.tar.gz" dir)))))
        (when tarball
          (uiop:run-program (list "tar" "xzf" (namestring tarball) "-C" (namestring dir))
                            :ignore-error-status t)
          (first (uiop:subdirectories dir)))))))

(defun find-root-asd (dir system-name)
  "Pick the .asd in DIR whose basename equals SYSTEM-NAME (ignoring any path
prefix); skip *.test.asd; else fall back to the shortest-named .asd."
  (let* ((asds (remove-if (lambda (p) (search ".test" (pathname-name p)))
                          (directory (merge-pathnames "*.asd" dir))))
         (base (let ((slash (position #\/ system-name :from-end t)))
                 (if slash (subseq system-name (1+ slash)) system-name))))
    (or (find system-name asds :key #'pathname-name :test #'string=)
        (find base asds :key #'pathname-name :test #'string=)
        (first (sort (copy-list asds) #'< :key (lambda (p) (length (pathname-name p))))))))

(defun fetch-readme (dir)
  "Read a top-level README* in DIR (truncated). NIL if none."
  (let ((readme (first (sort (directory (merge-pathnames "README*" dir))
                             #'string< :key #'namestring))))
    (when readme
      (let ((text (ignore-errors (uiop:read-file-string readme))))
        (when text
          (if (> (length text) +readme-max-chars+)
              (subseq text 0 +readme-max-chars+)
              text))))))

(defun deps->json (deps)
  "Serialize a list of dependency name strings as a JSON array string."
  (with-output-to-string (s)
    (write-char #\[ s)
    (loop for (d . rest) on deps
          do (format s "~S" d)
             (when rest (write-char #\, s)))
    (write-char #\] s)))

(defun fetch-enrichment (row)
  "ROW is (id registry-name system-name). Do all the network-bound work — pull
versions + .asd metadata + README into a temp dir — and return an upsert-system
plist, or NIL on any error (logged to stderr). Touches NO database, so it is
safe to run concurrently in lparallel workers; the caller does the DB write."
  (destructuring-bind (id registry-name system-name) row
    (declare (ignore id))
    (handler-case
        (with-temp-dir (dir)
          (multiple-value-bind (tags latest) (system-versions registry-name)
            (declare (ignore tags))
            (let* ((art (fetch-artifact registry-name dir))
                   (asd (and art (find-root-asd art system-name)))
                   (meta (if asd (parse-asd asd) '())))
              (list :registry-name registry-name
                    :system-name   system-name
                    :description   (getf meta :description)
                    :author        (getf meta :author)
                    :license       (getf meta :license)
                    :homepage      nil
                    :latest        latest
                    :deps          (deps->json (getf meta :depends-on))
                    :readme        (and art (fetch-readme art))
                    :etag          nil
                    :fetched-at    (iso-now)))))
      (error (e)
        (format *error-output* "~&; enrich ~A failed: ~A~%" registry-name e)
        nil))))

(defun enrich-system (db row)
  "Fetch enrichment for ROW and write it. Returns T on success; NIL (leaving the
row enriched=0) on any fetch error. Used by the sequential enrichment path."
  (let ((data (fetch-enrichment row)))
    (when data
      (upsert-system db data)
      t)))
