519 lines
15 KiB
Racket
519 lines
15 KiB
Racket
#lang racket/base
|
|
|
|
(require
|
|
racket/file
|
|
racket/function
|
|
racket/hash
|
|
racket/list
|
|
racket/match
|
|
racket/port
|
|
racket/runtime-path
|
|
racket/sandbox
|
|
racket/sequence
|
|
racket/set
|
|
racket/string
|
|
|
|
net/url
|
|
pkg/lib
|
|
setup/getinfo)
|
|
|
|
(define main-dist-pkgs
|
|
(list->set (installed-pkg-names #:scope 'installation)))
|
|
|
|
(define (process-dep dep)
|
|
(match dep
|
|
[(? string? _) dep]
|
|
[(cons "base" _)
|
|
"base"]
|
|
[(cons name args*)
|
|
(let/ec exit
|
|
(define args
|
|
(for/list ([v (in-slice 2 args*)]) (cons (first v) (second v))))
|
|
(match (assq '#:platform args)
|
|
[(cons _ 'windows) (exit #f)]
|
|
[(cons _ 'unix) (void)]
|
|
[(cons _ plat) (error "unhandled platform" plat)]
|
|
[#f (void)])
|
|
(match (assq '#:version args)
|
|
[#f (void)]
|
|
[(cons _ _) (displayln "WARNING: unhandled version spec")])
|
|
name)]))
|
|
|
|
(define (process-deps deps)
|
|
(for/list ([dep (in-list deps)]
|
|
#:do [(define dep* (process-dep dep))]
|
|
#:when dep*
|
|
#:unless (set-member? main-dist-pkgs dep*))
|
|
dep*))
|
|
|
|
(define-runtime-path overrides-path "racket-catalog-overrides.rktd")
|
|
(define catalog-overrides (file->value overrides-path))
|
|
|
|
|
|
(define (racket-license->nix-license license)
|
|
(if license
|
|
(let ([lic-expr (with-input-from-string license read)])
|
|
`(list ,@(cvtl lic-expr)))
|
|
(begin
|
|
(displayln "WARNING: no license for package -- using unfree")
|
|
'(dot (dot lib licenses) unfree))))
|
|
|
|
|
|
(define (cvtl lic-expr)
|
|
(match lic-expr
|
|
[(? symbol? _)
|
|
(list `(dot (dot lib licensesSpdx) ,(symbol->string lic-expr)))]
|
|
[`(,a OR ,b)
|
|
(append (cvtl a) (cvtl b))]
|
|
[`(,a AND ,b)
|
|
(append (cvtl a) (cvtl b))]
|
|
[`(,a WITH ,b)
|
|
(error "unhandled with" lic-expr)]))
|
|
|
|
|
|
(define (module-name mod-spec)
|
|
(match mod-spec
|
|
[`(lib ,mod-name) mod-name]
|
|
[_ (error "unrecognized module spec" mod-spec)]))
|
|
|
|
|
|
(define (extract-path query)
|
|
(match (assq 'path query)
|
|
[#f #f]
|
|
[(cons _ value) value]))
|
|
|
|
|
|
;; (list 'github owner repo rev path)
|
|
;; (list 'git url rev path)
|
|
;; (list 'archive url)
|
|
;; - note if the archive contains a single directory inside, that dir is the top level
|
|
;; .plt is not supported
|
|
(define (normalize-source source checksum)
|
|
(define u (string->url source))
|
|
(match (string->url source)
|
|
[(or (url "github" _ _ _ _
|
|
(or
|
|
(list
|
|
(path/param owner '())
|
|
(path/param repo '()))
|
|
(list
|
|
(path/param owner '())
|
|
(path/param repo '())
|
|
; there might be a branch/tag -- ignore it and use "checksum" as rev
|
|
_))
|
|
(app extract-path path-maybe)
|
|
_)
|
|
(url (pregexp #px"^git|(git\\+)?https?$") _ "github.com" _ _
|
|
(list
|
|
(path/param owner '())
|
|
(path/param (pregexp #px"^(.*?)(\\.git)?$" (list _ repo _)) '()))
|
|
(app extract-path path-maybe)
|
|
_))
|
|
(list
|
|
'github
|
|
owner
|
|
repo
|
|
checksum
|
|
path-maybe)]
|
|
|
|
[(or (url "github" _ _ _ _ _ _ _)
|
|
(url (pregexp #px"^git|(git\\+)?https?$") _ "github.com" _ _ _ _ _))
|
|
(error "invalid github url" source)]
|
|
|
|
[(or (url (or "git" "git+http" "git+https") _ _ _ _ _
|
|
(app extract-path path-maybe)
|
|
_)
|
|
(url (or "http" "https") _ _ _ _
|
|
(or
|
|
(list _ ... (path/param (pregexp #px"\\.git$") '()))
|
|
(list _ ... (path/param (pregexp #px"\\.git$") '()) (path/param "" '())))
|
|
(app extract-path path-maybe)
|
|
_))
|
|
(define u*
|
|
(url
|
|
(url-scheme u)
|
|
(url-user u)
|
|
(url-host u)
|
|
(url-port u)
|
|
(url-path-absolute? u)
|
|
(url-path u)
|
|
'()
|
|
#f))
|
|
(list 'git (url->string u*) checksum path-maybe)]
|
|
|
|
[(url (or "http" "https") _ _ _ _
|
|
(list _ ... (path/param (pregexp #px"\\.(zip|tar|tgz|tar\\.gz)$") '()))
|
|
_ _)
|
|
(list 'archive source)]
|
|
|
|
[_ (error "unrecognized source url" source)]))
|
|
|
|
|
|
(define (extract-free-vars expr [scope (set)])
|
|
(match expr
|
|
[`(dot ,a ,(or (? symbol? b) (? string? b)))
|
|
(extract-free-vars a)]
|
|
[`(app ,fun ,arg)
|
|
(append (extract-free-vars fun scope)
|
|
(extract-free-vars arg scope))]
|
|
[`(attrs (,names ,values) ...)
|
|
(for/fold ([acc '()]) ([name (in-list names)] [value (in-list values)])
|
|
(append acc (extract-free-vars value scope)))]
|
|
[`(templatestring ,exprs ...)
|
|
(for/fold ([acc '()]) ([expr (in-list exprs)])
|
|
(append acc (extract-free-vars expr scope)))]
|
|
[`(list ,exprs ...)
|
|
(for/fold ([acc '()]) ([expr (in-list exprs)])
|
|
(append acc (extract-free-vars expr scope)))]
|
|
[(? symbol? _)
|
|
(if (set-member? scope expr)
|
|
'()
|
|
(list expr))]
|
|
[(? string? _) '()]
|
|
[(? boolean? _) '()]
|
|
[(? number? _) '()]))
|
|
|
|
|
|
(define (callpackageify expr)
|
|
(define free-vars (set->list (list->set (extract-free-vars expr))))
|
|
`(function
|
|
,free-vars
|
|
,expr))
|
|
|
|
|
|
(define (render-nix expr)
|
|
(match expr
|
|
[(or (? number? _)
|
|
(? symbol? _)
|
|
(? string? _))
|
|
(write expr)]
|
|
[(? boolean? _)
|
|
(write-string (if expr "true" "false"))]
|
|
[`(function ,vars ,expr)
|
|
(write-string "{\n")
|
|
(for ([var (in-list vars)])
|
|
(write var)
|
|
(write-string ",\n"))
|
|
(write-string "}:\n")
|
|
(render-nix expr)]
|
|
[`(app ,fun ,arg)
|
|
(write-string "(")
|
|
(render-nix fun)
|
|
(write-string " ")
|
|
(render-nix arg)
|
|
(write-string ")")]
|
|
[`(list ,exprs ...)
|
|
(write-string "[")
|
|
(for ([expr (in-list exprs)])
|
|
(write-string "(")
|
|
(render-nix expr)
|
|
(write-string ") "))
|
|
(write-string "]")]
|
|
[`(dot ,a ,b)
|
|
(write-string "(")
|
|
(render-nix a)
|
|
(write-string ").")
|
|
(render-nix b)]
|
|
[`(templatestring ,exprs ...)
|
|
(write-string "\"")
|
|
(for ([expr (in-list exprs)])
|
|
(if (string? expr)
|
|
(write-string expr)
|
|
(begin
|
|
(write-string "${")
|
|
(render-nix expr)
|
|
(write-string "}"))))
|
|
(write-string "\"")]
|
|
[`(attrs (,names ,values) ...)
|
|
(write-string "{\n")
|
|
(for ([name (in-list names)] [value (in-list values)])
|
|
(write name)
|
|
(write-string " = ")
|
|
(render-nix value)
|
|
(write-string ";\n"))
|
|
(write-string "}")])
|
|
(void))
|
|
|
|
|
|
(define (call-with-subprocess-env thk)
|
|
(parameterize ([current-subprocess-custodian-mode 'kill]
|
|
[current-environment-variables
|
|
(environment-variables-copy (current-environment-variables))])
|
|
(putenv "TERM" "dumb")
|
|
(putenv "NO_COLOR" "1")
|
|
(call-with-custodian-shutdown
|
|
thk)))
|
|
|
|
(define (subprocess/path/piped . args)
|
|
(define-values [proc stdout stdin stderr]
|
|
(apply subprocess #f #f 'stdout "/usr/bin/env" args))
|
|
(values proc stdout stdin))
|
|
|
|
|
|
(struct nix-repl [proc stdout stdin])
|
|
(define current-nix-repl (make-parameter #f))
|
|
|
|
|
|
(define (call-with-nix-repl thk)
|
|
(call-with-subprocess-env
|
|
(lambda ()
|
|
(define-values [proc stdout stdin]
|
|
(subprocess/path/piped
|
|
"nix"
|
|
"--extra-experimental-features"
|
|
"nix-command flakes pipe-operator repl-automation"
|
|
"repl" "--impure" "."))
|
|
|
|
(sync (regexp-match-evt #px"^[^\x05]+\x05" stdout))
|
|
|
|
(parameterize ([current-nix-repl (nix-repl proc stdout stdin)])
|
|
(thk)))))
|
|
|
|
(define (nix-eval line)
|
|
(match-define (nix-repl _ stdout stdin) (current-nix-repl))
|
|
(write-string line stdin)
|
|
(newline stdin)
|
|
(flush-output stdin)
|
|
|
|
(string-trim
|
|
(bytes->string/utf-8
|
|
(second
|
|
(sync (regexp-match-evt #px"^([^\x05]+)\x05" stdout))))))
|
|
|
|
|
|
(define (nix-format file*)
|
|
(displayln "formatting generated nix")
|
|
(define file (path->string file*))
|
|
(call-with-subprocess-env
|
|
(lambda ()
|
|
(define-values [proc stdout stdin]
|
|
(subprocess/path/piped
|
|
"alejandra" "--quiet" file))
|
|
(port->string stdout)
|
|
(subprocess-wait proc)))
|
|
(void))
|
|
|
|
|
|
(define (add-to-git-maybe file*)
|
|
(define file (path->string file*))
|
|
(call-with-subprocess-env
|
|
(lambda ()
|
|
(define-values (proc stdout stdin)
|
|
(subprocess/path/piped
|
|
"git" "rev-parse" "--show-toplevel"))
|
|
(port->string stdout)
|
|
(subprocess-wait proc)
|
|
|
|
(when (= 0 (subprocess-status proc))
|
|
(define-values [proc stdout stdin]
|
|
(subprocess/path/piped
|
|
"git" "add" file))
|
|
(port->string stdout)
|
|
(subprocess-wait proc)))))
|
|
|
|
|
|
(define (racket2nix
|
|
pkg-name
|
|
[force? #f]
|
|
[base-dir (build-path "racket-catalog")]
|
|
[acc (make-hash)])
|
|
(define pkg-dir (build-path base-dir pkg-name))
|
|
(when
|
|
(match (hash-ref acc pkg-name #f)
|
|
['pending (error "circular dependency!" pkg-name)]
|
|
['installed #f]
|
|
[#f (or (not (directory-exists? pkg-dir))
|
|
force?)])
|
|
|
|
(hash-set! acc pkg-name 'pending)
|
|
(printf "fetching info for ~a\n" pkg-name)
|
|
(define details* (get-pkg-details-from-catalogs pkg-name))
|
|
|
|
(define details
|
|
(if (hash-has-key? catalog-overrides pkg-name)
|
|
(hash-union
|
|
details*
|
|
(hash-ref catalog-overrides pkg-name)
|
|
#:combine/key (lambda (k v0 v) v))
|
|
details*))
|
|
|
|
(define description (hash-ref details 'description))
|
|
|
|
(define license (hash-ref details 'license))
|
|
(define nix-license (racket-license->nix-license license))
|
|
|
|
(define dependencies (process-deps (hash-ref details 'dependencies)))
|
|
(define nix-deps
|
|
`(list ,@(map string->symbol dependencies)))
|
|
|
|
(for ([dependency (in-list dependencies)])
|
|
(racket2nix dependency force? base-dir acc))
|
|
|
|
(define broken? (not (hash-ref (hash-ref details 'search-terms) ':build-success:)))
|
|
|
|
(define source (hash-ref details 'source))
|
|
(define checksum (hash-ref details 'checksum))
|
|
(define git-shorthash (substring checksum 0 7))
|
|
(define source-desc (normalize-source source checksum))
|
|
|
|
(define readme (hash-ref details 'readme-url))
|
|
|
|
(define modules* (hash-ref details 'modules))
|
|
(define modules (map module-name modules*))
|
|
|
|
(make-directory* pkg-dir)
|
|
|
|
(define (generate-spec
|
|
[nix-hash '(dot lib fakeHash)]
|
|
[version "0.0"]
|
|
[racket-launchers '()]
|
|
[raco-commands '()]
|
|
[format? #f])
|
|
(define-values (nix-src* subpath)
|
|
(match source-desc
|
|
[(list 'github owner repo rev path)
|
|
(values
|
|
`((src
|
|
(app
|
|
fetchFromGitHub
|
|
(attrs
|
|
(owner ,owner)
|
|
(repo ,repo)
|
|
(rev ,rev)
|
|
(hash ,nix-hash))))
|
|
(gitSubpath ,(or path ".")))
|
|
(or path 'same))]
|
|
[(list 'git url rev path)
|
|
(values
|
|
`((src
|
|
(app
|
|
fetchgit
|
|
(attrs
|
|
(url ,url)
|
|
(rev ,rev)
|
|
(hash ,nix-hash))))
|
|
(gitSubpath ,(or path ".")))
|
|
(or path 'same))]
|
|
[(list 'archive url)
|
|
(values
|
|
`(app
|
|
fetchzip
|
|
(attrs
|
|
(url ,url)
|
|
(hash ,nix-hash)))
|
|
'same)]))
|
|
|
|
(define nix-version (format "~a+~a" version git-shorthash))
|
|
|
|
(define nix-meta
|
|
`(attrs
|
|
(description ,description)
|
|
(sourceProvenance (list (dot (dot lib sourceTypes) fromSource)))
|
|
(broken ,broken?)
|
|
(license ,nix-license)
|
|
,@(if readme `((homepage ,readme)) '())
|
|
,@(if (and racket-launchers (not (empty? racket-launchers)))
|
|
`((mainProgram ,(first racket-launchers)))
|
|
'())))
|
|
|
|
(define nix-passthru
|
|
`(attrs
|
|
(racketModules (list ,@modules))
|
|
(racketLaunchers (list ,@racket-launchers))
|
|
(racoCommands (list ,@raco-commands))))
|
|
|
|
(define nix-spec*
|
|
`(app
|
|
buildRacketPackage
|
|
(attrs
|
|
(pname ,pkg-name)
|
|
(version ,nix-version)
|
|
(dependencies ,nix-deps)
|
|
,@nix-src*
|
|
(passthru ,nix-passthru)
|
|
(meta ,nix-meta))))
|
|
|
|
(define nix-spec (callpackageify nix-spec*))
|
|
|
|
(define default-nix (build-path pkg-dir "default.nix"))
|
|
|
|
(with-output-to-file default-nix
|
|
(lambda ()
|
|
(render-nix nix-spec))
|
|
#:exists 'replace)
|
|
|
|
(when format?
|
|
(nix-format default-nix))
|
|
|
|
(add-to-git-maybe default-nix)
|
|
|
|
subpath)
|
|
|
|
(generate-spec)
|
|
|
|
(displayln "fetching source")
|
|
|
|
(call-with-nix-repl
|
|
(lambda ()
|
|
(define drv-def-out
|
|
(nix-eval
|
|
(format "drv = with legacyPackages.${builtins.currentSystem}; instrumentedFetch (racketPackages.~a.src)" pkg-name)))
|
|
|
|
(unless (equal? drv-def-out "Added drv.")
|
|
(error "failed to eval package def" drv-def-out))
|
|
|
|
(define build-output (nix-eval ":b drv"))
|
|
(define build-log (nix-eval ":log drv"))
|
|
(define real-hash
|
|
(match build-log
|
|
[(pregexp #px"FETCH_HASH:([^:]+):FETCH_HASH" (list _ real-hash))
|
|
real-hash]
|
|
[_ (error "failed to retrieve src hash" build-output build-log)]))
|
|
|
|
(define subpath (generate-spec real-hash))
|
|
|
|
(nix-eval ":r")
|
|
(define drv-def-out-r
|
|
(nix-eval
|
|
(format "drv = with legacyPackages.${builtins.currentSystem}; instrumentedFetch (racketPackages.~a.src)" pkg-name)))
|
|
|
|
(unless (equal? drv-def-out-r "Added drv.")
|
|
(error "failed to eval package def" drv-def-out-r))
|
|
|
|
(define out-path (nix-eval ":p drv.outPath"))
|
|
(define build-log-2 (nix-eval ":b drv"))
|
|
|
|
(unless (directory-exists? out-path)
|
|
(error "failed to fetch source" out-path build-log-2))
|
|
|
|
(define info-proc (get-info/full (build-path out-path subpath)))
|
|
|
|
(define version (info-proc 'version (lambda () "0.0")))
|
|
(define racket-launchers (info-proc 'racket-launcher-names (lambda () '())))
|
|
(define raco-commands* (info-proc 'raco-commands (lambda () '())))
|
|
(define raco-commands
|
|
(and raco-commands*
|
|
(map first raco-commands*)))
|
|
|
|
(generate-spec real-hash version racket-launchers raco-commands #t)
|
|
|
|
(displayln "doing final module build")
|
|
(nix-eval ":r")
|
|
(define drv-def-out-final
|
|
(nix-eval
|
|
(format "drv = with legacyPackages.${builtins.currentSystem}; racketPackages.~a" pkg-name)))
|
|
(unless (equal? drv-def-out-final "Added drv.")
|
|
(error "failed to eval package def" drv-def-out-final))
|
|
(define out-path-final (nix-eval ":p drv.outPath"))
|
|
(define build-output-final
|
|
(nix-eval ":b drv"))
|
|
|
|
(unless (directory-exists? out-path-final)
|
|
(error "failed to do final build" out-path-final build-output-final))
|
|
|
|
(void)))
|
|
|
|
(hash-set! acc pkg-name 'installed)
|
|
|
|
(void)))
|