import: Add %nvidia-updater.

* guix/import/nvidia.scm: New file. Modified-by: Hilton Chain <hako@ultrarare.space> Signed-off-by: Hilton Chain <hako@ultrarare.space>
author: Nicolas Graves <ngraves@ngraves.fr> 2024-09-24 17:47:58 +0200
committer: Hilton Chain <hako@ultrarare.space> 2024-11-28 14:24:24 +0800
commit: a21f4975048ed2f619cd0a0a3c1982d64dd5b7c6 (patch)
tree: d8c857df726f60e95dd543017ca0f5afa455630f
parent: 3d54c63d35b6da6a2a195087a1f3d325cf25ac2a (diff)
1 files changed, 121 insertions, 0 deletions
diff --git a/guix/import/nvidia.scm b/guix/import/nvidia.scm
new file mode 100644
index 0000000..49ca159
--- /dev/null
+++ b/guix/import/nvidia.scm
@@ -0,0 +1,121 @@
+;;; SPDX-License-Identifier: GPL-3.0-or-later
+;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
+;;; This file is not part of GNU Guix but requires this naming scheme
+;;; so that the %nvidia-updater is properly read when using
+;;; `guix refresh -L$(pwd) nvidia-driver' in nonguix root.
+(define-module (guix import nvidia)
+  #:use-module (web client)
+  #:use-module (sxml match)
+  #:use-module (sxml simple)
+  #:use-module (guix memoization)
+  #:use-module (guix packages)
+  #:use-module (guix upstream)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
+  #:export (%nvidia-updater))
+(define nvidia-latest-url "https://www.nvidia.com/en-us/drivers/unix/")
+(define (archive->guix-arch system)
+  (match system
+    ("https://www.nvidia.com/object/linux-amd64-display-archive.html"
+     "x86_64-linux")
+    ("https://www.nvidia.com/en-us/drivers/unix/linux-aarch64-archive/"
+     "aarch64-linux")
+    (_ #f)))
+(define (archive? cand)
+  (or (string= cand (string-append nvidia-latest-url "linux-aarch64-archive/"))
+      (and (string-prefix? "https://www.nvidia.com/object/" cand)
+           (string-suffix? "-archive.html" cand))))
+(define nvidia-versions
+  (memoize
+   (lambda _
+     (let* ((response content (http-get nvidia-latest-url))
+            (match-str (string-match "<div id=\"rightContent\".*</div>"
+                                     content))
+            (greedy-right-content (match:substring match-str))
+            (match-str (string-match "</div>" greedy-right-content))
+            (right-content
+             (string-append (match:prefix match-str) "</div>"))
+            ;; xml->sxml is not flexible enough for html.
+            ;; For instance, <br> tags don't have closing </br>.
+            ;; This trick preprocesses html to extract all <a> tags in
+            ;; a <body> wrapper, which sxml-match can handle well.
+            (xml (xml->sxml
+                  (string-append
+                   "<body><"
+                   (string-join
+                    (filter (cute string-prefix? "a " <>)
+                            (string-split right-content #\<))
+                    "</a><")
+                   "</a></body>")
+                  #:trim-whitespace? #t))
+            (link-alist
+             (sxml-match
+              xml
+              ((*TOP*
+                (body
+                 (a (@ (href ,url)) ,version) ...))
+               (fold acons
+                     '()
+                     (list (or (string= version "Archive")
+                               (string-trim version))
+                           ...)
+                     (list (if (archive? url)
+                               (archive->guix-arch url)
+                               url)
+                           ...)))))
+            (system #f)
+            (versions
+             (fold
+              (lambda (el rest)
+                (match el
+                  (`(#t . ,s)
+                   (set! system s)
+                   rest)
+                  (`(,version . ,address)
+                   ;; aarch64 seems to follow the same driver versions than x86_64
+                   ;; KISS: use only an alist of versions
+                   ;; go for an alist of alists insted if they diverge
+                   (if (and (string? system) (string= system "x86_64-linux"))
+                       (cons version rest)
+                       rest))
+                  (_ rest)))
+              '()
+              link-alist)))
+       (fold acons '() (list "main" "latest" "beta") (take versions 3))))))
+(define* (latest-release package #:key (version #f))
+  "Return an <upstream-source> for the latest-release of PACKAGE."
+  (let* ((name (package-name package))
+         (kind (match name
+                 ("nvidia-driver" "main")
+                 ("nvidia-driver-beta" "beta")))
+         (version (or version (assoc-ref (nvidia-versions) kind))))
+    (upstream-source
+     (package name)
+     (version version)
+     (urls (list (string-append
+                  "https://us.download.nvidia.com/XFree86/Linux-x86_64/"
+                  version "/NVIDIA-Linux-x86_64-" version ".run"))))))
+(define (nvidia-package? package)
+  "Return true if PACKAGE is Nvidia."
+  (member (package-name package)
+          (list "nvidia-driver" "nvidia-driver-beta")))
+(define %nvidia-updater
+  (upstream-updater
+   (name 'nvidia)
+   (description "Updater for Nvidia packages")
+   (pred nvidia-package?)
+   (import latest-release)))
+;; nvidia.scm ends here.
author	Nicolas Graves <ngraves@ngraves.fr>	2024-09-24 17:47:58 +0200
committer	Hilton Chain <hako@ultrarare.space>	2024-11-28 14:24:24 +0800
commit	a21f4975048ed2f619cd0a0a3c1982d64dd5b7c6 (patch)
tree	d8c857df726f60e95dd543017ca0f5afa455630f
parent	3d54c63d35b6da6a2a195087a1f3d325cf25ac2a (diff)

diff --git a/guix/import/nvidia.scm b/guix/import/nvidia.scm new file mode 100644 index 0000000..49ca159 --- /dev/null +++ b/guix/import/nvidia.scm
@@ -0,0 +1,121 @@
	1	;;; SPDX-License-Identifier: GPL-3.0-or-later
	2	;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
	3
	4	;;; This file is not part of GNU Guix but requires this naming scheme
	5	;;; so that the %nvidia-updater is properly read when using
	6	;;; `guix refresh -L$(pwd) nvidia-driver' in nonguix root.
	7
	8	(define-module (guix import nvidia)
	9	#:use-module (web client)
	10	#:use-module (sxml match)
	11	#:use-module (sxml simple)
	12	#:use-module (guix memoization)
	13	#:use-module (guix packages)
	14	#:use-module (guix upstream)
	15	#:use-module (ice-9 match)
	16	#:use-module (ice-9 regex)
	17	#:use-module (srfi srfi-1)
	18	#:use-module (srfi srfi-26)
	19	#:use-module (srfi srfi-71)
	20	#:export (%nvidia-updater))
	21
	22	(define nvidia-latest-url "https://www.nvidia.com/en-us/drivers/unix/")
	23
	24	(define (archive->guix-arch system)
	25	(match system
	26	("https://www.nvidia.com/object/linux-amd64-display-archive.html"
	27	"x86_64-linux")
	28	("https://www.nvidia.com/en-us/drivers/unix/linux-aarch64-archive/"
	29	"aarch64-linux")
	30	(_ #f)))
	31
	32	(define (archive? cand)
	33	(or (string= cand (string-append nvidia-latest-url "linux-aarch64-archive/"))
	34	(and (string-prefix? "https://www.nvidia.com/object/" cand)
	35	(string-suffix? "-archive.html" cand))))
	36
	37	(define nvidia-versions
	38	(memoize
	39	(lambda _
	40	(let* ((response content (http-get nvidia-latest-url))
	41	(match-str (string-match "<div id=\"rightContent\".*</div>"
	42	content))
	43	(greedy-right-content (match:substring match-str))
	44	(match-str (string-match "</div>" greedy-right-content))
	45	(right-content
	46	(string-append (match:prefix match-str) "</div>"))
	47	;; xml->sxml is not flexible enough for html.
	48	;; For instance, <br> tags don't have closing </br>.
	49	;; This trick preprocesses html to extract all <a> tags in
	50	;; a <body> wrapper, which sxml-match can handle well.
	51	(xml (xml->sxml
	52	(string-append
	53	"<body><"
	54	(string-join
	55	(filter (cute string-prefix? "a " <>)
	56	(string-split right-content #\<))
	57	"</a><")
	58	"</a></body>")
	59	#:trim-whitespace? #t))
	60	(link-alist
	61	(sxml-match
	62	xml
	63	((TOP
	64	(body
	65	(a (@ (href ,url)) ,version) ...))
	66	(fold acons
	67	'()
	68	(list (or (string= version "Archive")
	69	(string-trim version))
	70	...)
	71	(list (if (archive? url)
	72	(archive->guix-arch url)
	73	url)
	74	...)))))
	75	(system #f)
	76	(versions
	77	(fold
	78	(lambda (el rest)
	79	(match el
	80	(`(#t . ,s)
	81	(set! system s)
	82	rest)
	83	(`(,version . ,address)
	84	;; aarch64 seems to follow the same driver versions than x86_64
	85	;; KISS: use only an alist of versions
	86	;; go for an alist of alists insted if they diverge
	87	(if (and (string? system) (string= system "x86_64-linux"))
	88	(cons version rest)
	89	rest))
	90	(_ rest)))
	91	'()
	92	link-alist)))
	93	(fold acons '() (list "main" "latest" "beta") (take versions 3))))))
	94
	95	(define* (latest-release package #:key (version #f))
	96	"Return an <upstream-source> for the latest-release of PACKAGE."
	97	(let* ((name (package-name package))
	98	(kind (match name
	99	("nvidia-driver" "main")
	100	("nvidia-driver-beta" "beta")))
	101	(version (or version (assoc-ref (nvidia-versions) kind))))
	102	(upstream-source
	103	(package name)
	104	(version version)
	105	(urls (list (string-append
	106	"https://us.download.nvidia.com/XFree86/Linux-x86_64/"
	107	version "/NVIDIA-Linux-x86_64-" version ".run"))))))
	108
	109	(define (nvidia-package? package)
	110	"Return true if PACKAGE is Nvidia."
	111	(member (package-name package)
	112	(list "nvidia-driver" "nvidia-driver-beta")))
	113
	114	(define %nvidia-updater
	115	(upstream-updater
	116	(name 'nvidia)
	117	(description "Updater for Nvidia packages")
	118	(pred nvidia-package?)
	119	(import latest-release)))
	120
	121	;; nvidia.scm ends here.