Skip to content

Commit

Permalink
refactor(spec): unify with defines
Browse files Browse the repository at this point in the history 
Signed-off-by: Kaiyang Wu <self@origincode.me>
  • Loading branch information
@OriginCode
OriginCode committed Feb 11, 2025
1 parent e78c314 commit 6ea683b
Show file tree
Hide file tree
Showing 4 changed files with 175 additions and 145 deletions.
39 changes: 20 additions & 19 deletions aosc/main.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,27 +6,28 @@

;; Probably like this?
;(define sample-package
; (define ver "1.0.0")
; (define version "1.0.0")
; (package
; (section "app-utils")
; (spec #:ver ver
; #:srcs (hash 'any (list
; (git "https://github.com/sample/sample"
; #:options
; (list (copy-repo? #t)
; (commit (string-append "tags/v" ver)))))
; 'arm64 (list
; (git "https://github.com/sample/sample-arm64"
; #:options
; (list (copy-repo? #t)
; (commit (string-append "tags/v" ver))))))
; #:chksums (list (skip))
; #:chkupdate (anitya 114514))
; (defines #:pkgname "sample"
; #:pkgdes "A sample package"
; #:pkgdep (list "glibc")
; #:builddep (list "meson" "ninja")
; #:pkgsec "utils")))
; (spec (ver version)
; #:srcs (srcs (hash 'any (list
; (git "https://github.com/sample/sample"
; #:options
; (list (copy-repo? #t)
; (commit (string-append "tags/v" ver)))))
; 'arm64 (list
; (git "https://github.com/sample/sample-arm64"
; #:options
; (list (copy-repo? #t)
; (commit (string-append "tags/v" ver))))))
; #:chksums (chksums (list (skip)))
; #:chkupdate (chkupdate (anitya 114514)))
; (defines (pkgname "sample")
; (pkgdes "A sample package")
; (pkgdep (list "glibc"))
; (builddep (list "meson" "ninja"))
; (pkgsec "utils")))
; ))

(struct package (section spec defines))

Expand Down
177 changes: 97 additions & 80 deletions aosc/private/spec.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,10 +14,10 @@
rename
submodule
copy-repo?
src?
src-type?
git
tbl
chksum?
chksum-type?
skip
checksum
anitya
Expand All @@ -27,13 +27,20 @@
git-generic
html
(contract-out
[struct spec-type ((ver string?)
(rel exact-nonnegative-integer?)
(srcs (or/c (hash/c arch? (listof src?)) (listof src?)))
(subdir string?)
(chksums (or/c (hash/c arch? (listof chksum?)) (listof chksum?)))
[struct ver ((val string?))]
[struct rel ((val exact-nonnegative-integer?))]
[struct srcs ((val (or/c (hash/c arch? (listof src-type?)) (listof src-type?))))]
[struct subdir ((val string?))]
[struct chksums ((val (or/c (hash/c arch? (listof chksum-type?)) (listof chksum-type?))))]
[struct chkupdate ((val chkupdate-type?))]
[struct dummysrc? ((val boolean?))]
[struct spec-type ((ver ver?)
(rel rel?)
(srcs srcs?)
(subdir subdir?)
(chksums chksums?)
(chkupdate chkupdate?)
(dummysrc? boolean?))])
(dummysrc? dummysrc??))])
spec
write-spec)

Expand Down Expand Up @@ -73,73 +80,76 @@

;; SRCS= field
;;=============
(struct src (type options value) #:transparent)
(struct src-type (type options value) #:transparent)
(struct srcs (val) #:transparent)

(define/contract (git url #:options [options null])
(->* (string?) (#:options (listof src-option?)) src?)
(src 'git options url))
(->* (string?) (#:options (listof src-option?)) src-type?)
(src-type 'git options url))

(define/contract (tbl url #:options [options null])
(->* (string?) (#:options (listof src-option?)) src?)
(->* (string?) (#:options (listof src-option?)) src-type?)
(define allowed-options '(rename))
(for ([opt (in-list options)]
#:when (not (member (src-option-field opt) allowed-options)))
(raise-user-error 'tbl "~a option is not allowed in tbl source" (src-option-field opt)))
(src 'tbl options url))
(src-type 'tbl options url))

(define/contract (src->string src)
(-> src? string?)
(string-join `(,(symbol->string (src-type src))
,@(if (null? (src-options src))
(-> src-type? string?)
(string-join `(,(symbol->string (src-type-type src))
,@(if (null? (src-type-options src))
null
(list (string-join (for/list ([opt (src-options src)])
(list (string-join (for/list ([opt (src-type-options src)])
(format "~a=~a"
(src-option-field opt)
(src-option-value opt)))
";")))
,(src-value src))
,(src-type-value src))
"::"))

(define/contract (srcs->string srcs [arch 'any])
(->* ((listof src?)) (arch?) string?)
(->* ((listof src-type?)) (arch?) string?)
(spec-entry->string "SRCS" (string-join (map src->string srcs)) #t arch))

;; CHKSUMS= field
;;================
(struct chksum (type value) #:transparent)
(struct chksum-type (type value) #:transparent)
(struct chksums (val) #:transparent)

(define/contract (checksum algorithm value)
(-> algorithm? string? chksum?)
(chksum algorithm value))
(-> algorithm? string? chksum-type?)
(chksum-type algorithm value))

(define/contract (skip)
(-> chksum?)
(chksum 'skip #f))
(-> chksum-type?)
(chksum-type 'skip #f))

(define/contract (chksum->string chksum)
(-> chksum? string?)
(if (equal? (chksum-type chksum) 'skip)
(-> chksum-type? string?)
(if (equal? (chksum-type-type chksum) 'skip)
"SKIP"
(format "~a::~a" (chksum-type chksum) (chksum-value chksum))))
(format "~a::~a" (chksum-type-type chksum) (chksum-type-value chksum))))

(define/contract (chksums->string chksums [arch 'any])
(->* ((listof chksum?)) (arch?) string?)
(->* ((listof chksum-type?)) (arch?) string?)
(spec-entry->string "CHKSUMS"
(string-join (map chksum->string chksums))
#t
arch))

;; CHKUPDATE= field (https://wiki.aosc.io/developer/packaging/aosc-findupdate/)
;;==================
(struct chkupdate (type value) #:transparent)
(struct chkupdate-type (type value) #:transparent)
(struct chkupdate (val) #:transparent)

(define/contract (anitya id)
(-> exact-nonnegative-integer? chkupdate?)
(chkupdate 'anitya (format "id=~a" id)))
(-> exact-nonnegative-integer? chkupdate-type?)
(chkupdate-type 'anitya (format "id=~a" id)))

(define/contract (github repo (pattern #f) [sort-version #f])
(->* (string?) (string? boolean?) chkupdate?)
(chkupdate 'github
(->* (string?) (string? boolean?) chkupdate-type?)
(chkupdate-type 'github
(string-append (string-append "repo=" repo)
(if pattern
(string-append ";pattern=" pattern)
Expand All @@ -151,8 +161,8 @@
""))))

(define/contract (gitlab repo [instance #f] (pattern #f) [sort-version #f])
(->* (string?) (string? string? boolean?) chkupdate?)
(chkupdate 'gitlab
(->* (string?) (string? string? boolean?) chkupdate-type?)
(chkupdate-type 'gitlab
(string-append (string-append "repo=" repo)
(if instance
(string-append ";instance=" instance)
Expand All @@ -167,98 +177,105 @@
""))))

(define/contract (gitweb url (pattern #f))
(->* (string?) (string?) chkupdate?)
(chkupdate 'gitweb
(->* (string?) (string?) chkupdate-type?)
(chkupdate-type 'gitweb
(string-append (string-append "url=" url)
(if pattern
(string-append ";pattern=" pattern)
""))))

(define/contract (git-generic url (pattern #f))
(->* (string?) (string?) chkupdate?)
(chkupdate 'git
(->* (string?) (string?) chkupdate-type?)
(chkupdate-type 'git
(string-append (string-append "url=" url)
(if pattern
(string-append ";pattern=" pattern)
""))))

(define/contract (html url pattern)
(-> string? string? chkupdate?)
(chkupdate 'gitweb (string-append "url=" url ";pattern=" pattern)))
(-> string? string? chkupdate-type?)
(chkupdate-type 'gitweb (string-append "url=" url ";pattern=" pattern)))

(define/contract (chkupdate->string chkupdate)
(-> chkupdate? string?)
(-> chkupdate-type? string?)
(spec-entry->string
"CHKUPDATE"
(format "~a::~a" (chkupdate-type chkupdate) (chkupdate-value chkupdate))
(format "~a::~a" (chkupdate-type-type chkupdate) (chkupdate-type-value chkupdate))
#t))

(struct ver (val) #:transparent)
(struct rel (val) #:transparent)
(struct subdir (val) #:transparent)
(struct dummysrc? (val) #:transparent)

;; Whole `spec` file struct
(struct spec-type (ver rel srcs subdir chksums chkupdate dummysrc?)
#:transparent)

;; `spec` constructor
(define/contract (spec #:ver ver
(define/contract (spec ver
#:rel [rel #f]
#:srcs [srcs null]
#:srcs [srcs #f]
#:subdir [subdir #f]
#:chksums [chksums null]
#:chksums [chksums #f]
#:chkupdate [chkupdate #f]
#:dummysrc? [dummysrc? #f])
(->* (#:ver string?)
(#:rel exact-nonnegative-integer?
#:srcs (or/c (hash/c arch? (listof src?)) (listof src?))
#:subdir string?
#:chksums (or/c (hash/c arch? (listof chksum?)) (listof chksum?))
(->* (ver?)
(#:rel rel?
#:srcs srcs?
#:subdir subdir?
#:chksums chksums?
#:chkupdate chkupdate?
#:dummysrc? boolean?)
#:dummysrc? dummysrc??)
spec-type?)
;; Checks
(when (xor (list? srcs) (list? chksums))
(raise-user-error 'spec "SRCS and CHKSUMS should have the same contract"))
(when (and (or (null? srcs)
(null? chksums)
(hash-empty? srcs)
(hash-empty? chksums))
(not dummysrc?))
(when (and (or (not srcs?)
(not chksums?)
(null? (srcs-val srcs))
(null? (chksums-val chksums))
(hash-empty? (srcs-val srcs))
(hash-empty? (chksums-val chksums)))
(not (or dummysrc? (dummysrc?-val dummysrc?))))
(raise-user-error 'spec "either add SRCS and CHKSUMS or specify DUMMYSRC"))
(when (and (hash? srcs)
(not (equal? (hash-keys srcs #t) (hash-keys chksums #t))))
(when (xor (list? (srcs-val srcs)) (list? (chksums-val chksums)))
(raise-user-error 'spec "SRCS and CHKSUMS should have the same contract"))
(when (and (hash? (srcs-val srcs))
(not (equal? (hash-keys (srcs-val srcs) #t) (hash-keys (chksums-val chksums) #t))))
(raise-user-error 'spec "SRCS and CHKSUMS have mismatching ARCH args"))
(unless (if (list? srcs)
(equal? (length srcs) (length chksums))
(unless (if (list? (srcs-val srcs))
(equal? (length (srcs-val srcs)) (length (chksums-val chksums)))
(andmap (λ (s c) (equal? (length s) (length c)))
(hash->list srcs #t)
(hash->list chksums #t)))
(hash->list (srcs-val srcs) #t)
(hash->list (chksums-val chksums) #t)))
(raise-user-error 'spec "SRCS and CHKSUMS length mismatch"))

;; Final struct
(spec-type ver rel srcs subdir chksums chkupdate dummysrc?))

(define/contract (write-spec spec out)
(-> spec-type? output-port? void?)
(displayln (spec-entry->string "VER" (spec-type-ver spec)) out)
(displayln (spec-entry->string "VER" (ver-val (spec-type-ver spec))) out)
(when (spec-type-rel spec)
(displayln (spec-entry->string "REL" (spec-type-rel spec)) out))
(displayln (spec-entry->string "REL" (rel-val (spec-type-rel spec))) out))
(unless (spec-type-dummysrc? spec)
(if (list? (spec-type-srcs spec))
(displayln (srcs->string (spec-type-srcs spec)) out)
(for ([arch-srcs (hash->list (spec-type-srcs spec))])
(if (list? (srcs-val (spec-type-srcs spec)))
(displayln (srcs->string (srcs-val (spec-type-srcs spec))) out)
(for ([arch-srcs (hash->list (srcs-val (spec-type-srcs spec)))])
(displayln (srcs->string (cdr arch-srcs) (car arch-srcs)) out))))
(when (spec-type-subdir spec)
(displayln (spec-entry->string "SUBDIR" (spec-type-subdir spec) #t) out))
(displayln (spec-entry->string "SUBDIR" (subdir-val (spec-type-subdir spec)) #t) out))
(unless (spec-type-dummysrc? spec)
(if (list? (spec-type-chksums spec))
(displayln (chksums->string (spec-type-chksums spec)) out)
(for ([arch-chksums (hash->list (spec-type-chksums spec))])
(if (list? (chksums-val (spec-type-chksums spec)))
(displayln (chksums->string (chksums-val (spec-type-chksums spec))) out)
(for ([arch-chksums (hash->list (chksums-val (spec-type-chksums spec)))])
(displayln (chksums->string (cdr arch-chksums) (car arch-chksums)) out))))
(when (spec-type-chkupdate spec)
(displayln (chkupdate->string (spec-type-chkupdate spec)) out))
(displayln (chkupdate->string (chkupdate-val (spec-type-chkupdate spec))) out))
(when (spec-type-dummysrc? spec)
(displayln
(spec-entry->string "DUMMYSRC"
(number->string (boolean->exact-nonnegative-integer
(spec-type-dummysrc? spec))))
(dummysrc?-val (spec-type-dummysrc? spec)))))
out)))

(module+ test
Expand Down Expand Up @@ -296,15 +313,15 @@
(test-suite "SRCS Git SRC tests"
(check-equal?
(git "https://github.com/NVIDIA/nvidia-settings")
(src 'git null "https://github.com/NVIDIA/nvidia-settings")
(src-type 'git null "https://github.com/NVIDIA/nvidia-settings")
"SRCS git no options")
(check-equal? (git "https://github.com/NVIDIA/nvidia-settings"
#:options
(list (copy-repo? #t)
(rename "nvidia")
(commit (string-append "tags/v" "0.0.1"))
(submodule 'recursive)))
(src 'git
(src-type 'git
(list (copy-repo? #t)
(rename "nvidia")
(commit (string-append "tags/v" "0.0.1"))
Expand Down Expand Up @@ -341,15 +358,15 @@
(tbl
"https://download.racket-lang.org/releases/8.15/installers/racket-8.15-src.tgz"
#:options (list (rename "racket")))
(src
(src-type
'tbl
(list (rename "racket"))
"https://download.racket-lang.org/releases/8.15/installers/racket-8.15-src.tgz")
"SRCS tbl with options")
(check-equal?
(tbl
"https://download.racket-lang.org/releases/8.15/installers/racket-8.15-src.tgz")
(src
(src-type
'tbl
null
"https://download.racket-lang.org/releases/8.15/installers/racket-8.15-src.tgz")
Expand Down
Loading

0 comments on commit 6ea683b

Please sign in to comment.