(use-modules (guix import json) (guix build utils) (guix import utils) (guix http-client) (srfi srfi-34) (ice-9 regex) (ice-9 textual-ports) (json)) ;; from https://gitlab.com/swedebugia/guix/blob/08fc0ec6fa76d95f4b469aa85033f1b0148f7fa3/guix/import/npm.scm (define (node->package-name name) "Given the NAME of a package on npmjs, return a Guix-compliant name for the package. We remove the '@' and keep the '/' in scoped packages. E.g. @mocha/test -> node-mocha/test" (cond ((and (string-prefix? "@" name) (string-prefix? "node-" name)) (snake-case (string-drop name 1))) ((string-prefix? "@" name) (string-append "node-" (snake-case (string-drop name 1)))) ((string-prefix? "node-" name) (snake-case name)) (else (string-append "node-" (snake-case name))))) (define (slash->_ name) (if (string-match "[/]" name) (regexp-substitute #f (string-match "/+" name) 'pre "_slash_" 'post) ;;else name)) (define (read-file file) (call-with-input-file file (lambda (port) (json->scm port)))) ;; from ;; http://git.savannah.gnu.org/cgit/guix.git/tree/guix/import/json.scm ;; adapted to return unaltered JSON (define* (http-fetch url ;; Note: many websites returns 403 if we omit a ;; 'User-Agent' header. #:key (headers `((user-agent . "GNU Guile") (Accept . "application/json")))) "Return a JSON resource URL, or #f if URL returns 403 or 404. HEADERS is a list of HTTP headers to pass in the query." (guard (c ((and (http-get-error? c) (let ((error (http-get-error-code c))) (or (= 403 error) (= 404 error)))) #f)) (let* ((port (http-fetch url #:headers headers)) ;; changed the upstream here to return unaltered json: (result (get-string-all port))) (close-port port) result))) (define (cache-handler name) ;;check if cached in cache-dir (let* ((cache-dir (string-append (getenv "HOME") "/.cache/npm-explorer")) ;; sanitize name to fit in cli-context on disk ;; it can contain @ and / (cache-name (slash->_ (node->package-name name))) (filename (string-append cache-dir "/" cache-name ".package.json"))) (if (file-exists? filename) ;;yes (read-file filename) ;;no (begin (when (not (directory-exists? cache-dir)) (mkdir-p cache-dir)) ;; port closes when this closes (call-with-output-file filename (lambda (port) (display ;; this gives os the result-closure and we write it out (http-fetch (string-append "https://registry.npmjs.org/" name)) port))) ;; get the content and close (read-file filename))))) (define (get-npm-module-dot name done level) (if (member name done) done ;; convert return from cache to hashtable (let ((descr (cache-handler name))) (if descr (catch #t (lambda () (let* ((latest (hash-ref (hash-ref descr "dist-tags") "latest")) (descr (hash-ref (hash-ref descr "versions") latest)) (devdeps (hash-ref descr "devDependencies")) (deps (hash-ref descr "dependencies"))) (if deps (hash-fold (lambda (key value acc) (begin (format (current-error-port) "level ~a: ~a packages \r" level (length acc)) (format #t "\"~a\" -> \"~a\";~%" name key) (get-npm-module-dot key acc (+ 1 level)))) (cons name done) deps) (cons name done)))) (lambda _ (format #t "~a [color=red];~%" name) (cons name done))) (cons name done))))) ;; (format #t "digraph dependencies {~%") ;; (format #t "overlap=false;~%") ;; (format #t "splines=true;~%") ;; (get-npm-module-dot "mocha" '() 0) ;; (format (current-error-port) "~%") ;; (format #t "}~%") ;;test ;;(display (slash->_ "babel/mocha")) ;works ;;(cache-handler "@babel/core") ;no errors but does not write to file. hmm.. (display "fetching") (newline) (display ;fails in a weird way... (http-fetch (string-append "https://registry.npmjs.org/" "mocha")))