124 lines
5.4 KiB
Scheme
124 lines
5.4 KiB
Scheme
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; raw.scm
|
||
|
|
;; Copyright (C) 2025 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 raw)
|
||
|
|
#:use-module (ebuild defs)
|
||
|
|
#:use-module (ebuild utils)
|
||
|
|
#:use-module (curl)
|
||
|
|
#:use-module (rx irregex)
|
||
|
|
#:use-module (ice-9 pretty-print)
|
||
|
|
#:use-module (ice-9 regex)
|
||
|
|
#:use-module (ice-9 string-fun)
|
||
|
|
#:use-module (srfi srfi-1)
|
||
|
|
#:use-module (dql dql))
|
||
|
|
|
||
|
|
(define-public fetch-raw
|
||
|
|
(lambda* (url extract-file extract-version asset-types #:key
|
||
|
|
(uri-prefix "")
|
||
|
|
(version-filter (lambda (version) #t))
|
||
|
|
(version-alter (lambda (version) version)))
|
||
|
|
"extract-file should extract the file name till the dot before the type."
|
||
|
|
(let ((curl-handle (curl-easy-init)))
|
||
|
|
(curl-easy-setopt curl-handle 'url url)
|
||
|
|
(curl-easy-setopt curl-handle 'useragent curl-useragent)
|
||
|
|
(let ((responce (curl-easy-perform curl-handle)))
|
||
|
|
(let ((releases (extract-file responce)))
|
||
|
|
(filter-map
|
||
|
|
(lambda (release)
|
||
|
|
(let ((version (version-alter (extract-version release))))
|
||
|
|
(if (version-filter version)
|
||
|
|
(list (cons "version" version)
|
||
|
|
(cons "assets"
|
||
|
|
(map
|
||
|
|
(lambda (type)
|
||
|
|
(list
|
||
|
|
(cons "uri"
|
||
|
|
(string-append
|
||
|
|
(if (string=? uri-prefix "")
|
||
|
|
(if (string-match
|
||
|
|
"^(http://|https://|ftp://)"
|
||
|
|
release)
|
||
|
|
"" url)
|
||
|
|
uri-prefix)
|
||
|
|
release type))
|
||
|
|
(cons "name" (string-append release type))
|
||
|
|
(cons "type" type)))
|
||
|
|
asset-types)))
|
||
|
|
#f)))
|
||
|
|
releases))))))
|
||
|
|
|
||
|
|
(define-public fetch-raw-html
|
||
|
|
(lambda* (url file-prefix
|
||
|
|
asset-types #:key
|
||
|
|
(uri-prefix "")
|
||
|
|
(version-filter (lambda (version) #t))
|
||
|
|
(version-alter (lambda (version) version))
|
||
|
|
(extract-version
|
||
|
|
(lambda (file)
|
||
|
|
(let ((my-match (irregex-search `(seq (+ num) "."
|
||
|
|
(+ num) "."
|
||
|
|
(+ num))
|
||
|
|
file)))
|
||
|
|
(if my-match
|
||
|
|
(irregex-match-substring my-match)))))
|
||
|
|
(file-postfix (car asset-types)))
|
||
|
|
""
|
||
|
|
(fetch-raw url
|
||
|
|
(lambda (responce)
|
||
|
|
;; Break up in lines, otherwise rx extremely expensive.
|
||
|
|
(filter-map
|
||
|
|
(lambda (line)
|
||
|
|
(let ((rx-match
|
||
|
|
(irregex-search
|
||
|
|
`(seq (look-behind "<a href=\"")
|
||
|
|
,file-prefix
|
||
|
|
(seq (+ num) "." (+ num) "." (+ num))
|
||
|
|
"."
|
||
|
|
(look-ahead ,(string-append file-postfix
|
||
|
|
"\">")))
|
||
|
|
line)))
|
||
|
|
(if rx-match
|
||
|
|
(irregex-match-substring rx-match)
|
||
|
|
#f)))
|
||
|
|
(string-split responce #\newline)))
|
||
|
|
extract-version
|
||
|
|
asset-types
|
||
|
|
#:uri-prefix uri-prefix
|
||
|
|
#:version-filter version-filter
|
||
|
|
#:version-alter version-alter)))
|
||
|
|
|
||
|
|
(define-public fetch-raw-release
|
||
|
|
(lambda (release type)
|
||
|
|
""
|
||
|
|
(let* ((my-file-data
|
||
|
|
(car ((dql (select (filter (select (parm-val "assets"))
|
||
|
|
(where (lambda (x)
|
||
|
|
(string=? x type))
|
||
|
|
"type"))
|
||
|
|
(parm "uri")
|
||
|
|
(parm "name")))
|
||
|
|
release)))
|
||
|
|
(uri (assoc-ref my-file-data "uri"))
|
||
|
|
(name (assoc-ref my-file-data "name"))
|
||
|
|
(file-path (string-append (assoc-ref release 'cache-path)
|
||
|
|
"/"
|
||
|
|
name)))
|
||
|
|
(mkpath (assoc-ref release 'cache-path))
|
||
|
|
(if (access? file-path F_OK)
|
||
|
|
(display "File already downloaded.\n")
|
||
|
|
(system* "/usr/bin/wget" "-O" file-path uri))
|
||
|
|
file-path)))
|