247 lines
9 KiB
Scheme
247 lines
9 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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))))
|