;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; npmjs.scm
;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published by the
;; Free Software Foundation, version 3 of the License.
;;
;; ebuild-autogen 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
;; ebuild-autogen. If not, see <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (ebuild fetchers npmjs)
  #:use-module (ebuild defs)
  #:use-module (ebuild fetchers raw)
  #:use-module (ebuild utils)
	#:use-module (ebuild pkt-map)
	#:use-module (ebuild semver)
  #:use-module (curl)
  #:use-module (json)
  #:use-module (ice-9 pretty-print)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-43)
  #:use-module (rx irregex)
  #:use-module (dql dql))

(define fetch-npmjs-pkg
  (lambda (pkg retries display-data)
    ""
    (let loop ((try 1))
			(let ((curl-handle (curl-easy-init)))
				;; Set the url to fetch.
				(curl-easy-setopt curl-handle
													'url
													(string-append "https://registry.npmjs.org/"
																				 pkg
																				 "/"))
				;; Set my user agent.
				(curl-easy-setopt curl-handle 'useragent curl-useragent)

				;; Set Connection Timeout in seconds
				(curl-easy-setopt curl-handle 'connecttimeout 5)

				;; Kill on a stalled connection.
				(curl-easy-setopt curl-handle 'low-speed-limit 120)
				(curl-easy-setopt curl-handle 'low-speed-time 12)

				(let* ((responce (curl-easy-perform curl-handle)))
					(curl-easy-cleanup curl-handle)

					(cond ((string? responce)
								 (let ((scm-responce (json-string->scm responce)))
									 (begin (if display-data
															(pretty-print scm-responce))
													scm-responce)))
								((<= try retries)
								 (sleep 10)
								 (loop (1+ try)))
								(else (error (string-append "npmjs fetch failed with error "
																						(curl-error-string)
																						"\n")))))))))

(define extract-deps
	(lambda (deps)
		(append-map
		 (lambda (dep)
			 (let* ((alias (car dep))
							(pkg-match
							 (irregex-search '(seq (look-behind (seq "npm:"))
																		 (? "@")
																		 (look-ahead (seq "@"
																											(? (or "^" "~" "<" ">"
																														 "<=" ">=" "*"
																														 "=" "=="))
																											(? space)
																											(+ num))))
															 (cdr dep)))
							(alt-slot-match
							 (irregex-search '(seq (look-behind (or bos "@" space)
																									(? (or "^" ">=" "<=" ">" "<")))
																		 (* num)
																		 (? "." (+ num)) ;; bugged spec...
																		 (look-ahead (seq "." (or "*" "x"))))
															 (cdr dep)))
							(alt-sub-slot-match
							 (irregex-search '(seq (look-behind (or bos "@" space)
																									(? (or "~" ">=" "<=" ">" "<")))
																		 (* num) "." (+ num)
																		 (look-ahead (seq "." (or "*" "x"))))
															 (cdr dep)))
							(vers-match
							 (cond (alt-slot-match
											(list (string-append "^"
																					 (irregex-match-substring
																						alt-slot-match))))
										 (alt-sub-slot-match
											(list (string-append "~"
																					 (irregex-match-substring
																						alt-sub-slot-match))))
										 (else (irregex-extract
														'(seq (look-behind (or bos "@" space))
																	(? (or "^" "~" "<" ">" "<=" ">=" "*" "=" "=="))
																	(? space)
																	(* num)
																	(* (or (seq "." (+ num))
																				 (seq "-" (+ alphanum))))
																	(look-ahead (or (seq "+"
																											 (+ (or alphanum "-"))
																											 eos)
																									(seq (+ space) eos)
																									eos)))
														(cdr dep))))))
				 (if (or (null? vers-match)
								 (every (lambda (answ)
													(string=? answ ""))
												vers-match))
						 (set! vers-match (list "*")))
				 (map (lambda (vers)
								(if (string=? vers "")
										'()
										(list (cons "alias" alias)
													(cons "pkg" (if pkg-match
																					(irregex-match-substring pkg-match)
																					alias))
													(cons "version" vers))))
							vers-match)))
		 deps)))

(define-public fetch-npmjs
  (lambda* (parms #:key
									(npm-name (if (assoc-ref parms 'npm-name)
																(assoc-ref parms 'npm-name)
																(assoc-ref parms 'name)))
									(file-types (list ".tgz"))
									(version-filter (lambda (version)
																		(semver->irregex-match version)))
									(version-alter (lambda (version) version))
									(version-values (lambda (version)
																		(semver->comps version)))
									(dep-alter (lambda (dep) dep))
									(display-data #f))
    ""
    (let* ((data (fetch-npmjs-pkg npm-name
																	(assoc-ref parms 'curl-retries)
																	display-data))
           (versions (assoc-ref data "versions"))
					 (pkt-map-db (pkt-map-load (assoc-ref parms 'repo) "nodejs")))
			;;(display "pkt-map-db-pre:") (newline)
			;;(pretty-print pkt-map-db)
			(set! pkt-map-db
						(pkt-map-set pkt-map-db
												 npm-name
												 (assoc-ref parms 'category)
												 (assoc-ref parms 'name)))
			;;(display "pkt-map-db-post:") (newline)
			;;(pretty-print pkt-map-db)
			(pkt-map-write pkt-map-db
										 (assoc-ref parms 'repo)
										 "nodejs")
      (filter-map
			 (lambda (version)
				 (let* ((my-data (car ((dql (select (parm "version")
																						(parm-as "sha256" "dist" "shasum")
																						(parm-as "uri" "dist" "tarball")
																						(parm-as "node" "_nodeVersion")
																						(parm-as "npm" "_npmVersion")
																						(parm "dependencies")
																						(parm "license")
																						(parm "homepage")
																						(parm "description"))
																		;;#:print-query npmjs-data
																		)
															 (cdr version))))
								(version-match (version-filter (assoc-ref my-data
																													"version"))))
					 ;; (display "my-data:") (newline)
					 ;; (pretty-print my-data)
					 (if (version-filter (assoc-ref my-data "version"))
							 (append
								(list (cons "version"
														(version-alter (assoc-ref my-data
																											"version"))))
								(list (cons "version-values"
														(semver->comps (assoc-ref my-data
																											"version")
																					 #:vers-match version-match)))
								(if (assoc-ref my-data "node")
										(list (assoc "node" my-data))
										'())
								(if (assoc-ref my-data "npm")
										(list (assoc "npm" my-data))
										'())
								(list (cons "npm-name" npm-name))
								(let ((license (if (list? (assoc-ref my-data "license"))
																	 (assoc-ref (assoc-ref my-data "license")
																							"type")
																	 (assoc-ref my-data "license"))))
									(cond
									 ((not license) '())
									 ((string=? license "UNLICENSED")
										(list (cons "license" "Unlicense")))
									 ((string=? license "BSD-3-Clause")
										(list (cons "license" "BSD")))
									 ((string=? license "BSD-2-Clause")
										(list (cons "license" "BSD-2")))
									 ((string=? license "Python-2.0")
										(list (cons "license" "PYTHON")))
									 (else (list (cons "license" license)))))
                (if (assoc-ref my-data "homepage")
										(list (assoc "homepage" my-data))
										'())
                (if (assoc-ref my-data "description")
										(list (cons "description"
																(irregex-replace/all
																 `(or #\` #\")
																 (assoc-ref my-data "description")
																 "'")))
										'())
								(if (and (assoc-ref my-data "dependencies")
												 (not (null? (assoc-ref my-data "dependencies"))))
										(list (cons "dependencies"
																(extract-deps (filter-map
																							 (lambda (dep)
																								 (dep-alter dep))
																							 (assoc-ref my-data
																													"dependencies")))))
										(list))
								(list
								 (cons "assets"
											 (list
												(append (list (assoc "sha256" my-data))
																(list (assoc "uri" my-data))
																(list (cons "type" ".tgz"))
																(list (cons "name"
																						(string-append
																						 "npm-"
																						 (assoc-ref parms 'name)
																						 "-"
																						 (assoc-ref my-data "version")
																						 ".tgz"))))))))
							 #f)))
       versions))))