implement initial racket2nix script

build-racket-package.nix

@@ -12,6 +12,7 @@
     "tetheredInstallation"
     "doMainSetup"
     "buildDocs"
+    "gitSubpath"
   ];
   extendDrvArgs = finalAttrs:
     {
@@ -25,6 +26,7 @@
       tetheredInstallation ? false,
       doMainSetup ? tetheredInstallation,
       buildDocs ? tetheredInstallation,
+      gitSubpath ? ".",
       ...
     } @ attrs: {
       name = "racket${racket.version}-" + pname + "-" + version;
@@ -37,6 +39,7 @@
       racketTetheredInstallation = tetheredInstallation;
       racketDoMainSetup = doMainSetup;
       racketBuildDocs = buildDocs;
+      racketGitSubpath = gitSubpath;
 
       nativeBuildInputs = [
         racket
@@ -56,6 +59,15 @@
                 wrapGApp "$f"
             fi
         done
-      '';
+      '' + (lib.optionalString (!tetheredInstallation) ''
+        find $out/bin -type f -executable -print0 |
+        while IFS= read -r -d ''' f; do
+            if test "$(file --brief --mime-type "$f")" = text/x-shellscript; then
+                substituteInPlace "$f" \
+                  --replace-fail "\"\''${bindir}/racket\"" \
+                                 "\"\''${bindir}/racket\" --config $out/etc/racket/"
+            fi
+        done
+      '');
     };
 }

overlay.nix

@@ -1,74 +1,27 @@
-final: prev: {
+final: prev: let
+  names = builtins.readDir ./racket-catalog |> final.lib.attrNames;
+  byName = self:
+    final.lib.map (name: {
+      inherit name;
+      value = self.callPackage ./racket-catalog/${name} {};
+    }) names |>
+    final.lib.listToAttrs;
+in {
   racket-minimal = final.callPackage ./racket/minimal.nix {};
   racket = final.callPackage ./racket/package.nix {};
 
+  instrumentedFetch = drv: drv.overrideAttrs (afinal: aprev: {
+    postFetch = (aprev.postFetch or "") + ''
+      printf "FETCH_HASH:%s:FETCH_HASH" "$(\
+        ${final.lib.getExe final.nix} --extra-experimental-features "nix-command" \
+          hash path --sri "$out")"
+    '';
+  });
+
   racketPackages = final.lib.makeScope final.newScope (self: {
     racketInstallHook = self.callPackage ./racket-install-hook.nix {};
     buildRacketPackage = self.callPackage ./build-racket-package.nix {};
 
     makeRacketEnv = self.callPackage ./make-racket-env.nix {};
-
-    testEnv = self.makeRacketEnv {
-      packages = [self.ansi-color self.curly-fn-lib];
-    };
-
-    ansi-color = self.callPackage (
-      {
-        lib,
-        buildRacketPackage,
-        fetchFromGitHub,
-      }: buildRacketPackage {
-        pname = "ansi-color";
-        version = "0.2";
-
-        src = final.fetchFromGitHub {
-          owner = "renatoathaydes";
-          repo = "ansi-color";
-          rev = "0.2";
-          hash = "sha256-7WDW+4R9K+XLb9nMNGQlU+zAi2Gq7cUqzO3csN+AJvI=";
-        };
-      }
-    ) {};
-
-    namespaced-transformer-lib = self.callPackage (
-      {
-        lib,
-        buildRacketPackage,
-        fetchFromGitHub,
-      }: buildRacketPackage {
-        pname = "namespaced-transformer-lib";
-        version = "none";
-
-        src = "${final.fetchFromGitHub {
-          owner = "lexi-lambda";
-          repo = "namespaced-transformer";
-          rev = "4cdc1bdae09a07b78f23665267f2c7df4be5a7f6";
-          hash = "sha256-vpDJ7qUNhKreig1LbU33d7TXXHkfd7gPxE1Fc5bvzFE=";
-        }}/namespaced-transformer-lib";
-      }
-    ) {};
-
-    curly-fn-lib = self.callPackage (
-      {
-        lib,
-        buildRacketPackage,
-        fetchFromGitHub,
-
-        namespaced-transformer-lib,
-      }: buildRacketPackage {
-        pname = "curly-fn-lib";
-        version = "none";
-
-        dependencies = [ namespaced-transformer-lib ];
-
-        src = "${final.fetchFromGitHub {
-          owner = "lexi-lambda";
-          repo = "racket-curly-fn";
-          rev = "d64cd71d5b386be85f5979edae6f6b6469a4df86";
-          hash = "sha256-ge7o/UAvUXA4DIl03UkqVnLHNaPGq4SqxWvpcKdXndI=";
-        }}/curly-fn-lib";
-      }
-    ) {};
-
-  });
+  } // (byName self));
 }

racket-catalog-overrides.rktd

@@ -0,0 +1 @@
+#hash()

racket-install-hook.sh

@@ -8,6 +8,7 @@ addRacketPath() {
 
 racketInstallPhase() {
   echo "Executing racketInstallPhase"
+  cd "$racketGitSubpath"
   runHook preInstall
 
   mkdir -p $out/{include,etc/racket,lib/racket,share/racket/pkgs,share/racket/collects,bin,share/applications,share/doc/racket,share/man}

racket2nix.rkt

@@ -0,0 +1,504 @@
+#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 *license-mapping*
+  (hash
+    'BSD-3-Clause '(dot (dot lib licenses) bsd3)
+    'MIT '(dot (dot lib licenses) mit)
+    'Apache-2.0 '(dot (dot lib licenses) asl20)
+    'LGPL-3.0-or-later '(dot (dot lib licenses) lgpl3Plus)
+    'Unicode-TOU '(dot (dot lib licenses) unicodeTOU)))
+
+(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
+       (or
+         (hash-ref *license-mapping* lic-expr #f)
+         (error "no license mapping defined for" 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 ,(? symbol? 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))
+
+(struct nix-repl [proc stdout stdin])
+
+(define current-nix-repl (make-parameter #f))
+
+(define (with-nix-repl 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
+      (lambda ()
+        (define-values (proc stdout stdin stderr)
+          (subprocess
+            #f #f 'stdout
+            "/usr/bin/env"
+            "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*))
+  (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
+      (lambda ()
+        (define-values (proc stdout stdin stderr)
+          (subprocess
+            #f #f 'stdout
+            "/usr/bin/env"
+            "alejandra"
+            "--quiet"
+            file))
+        (port->string stdout)
+        (subprocess-wait proc)))
+    (void)))
+
+(define (add-to-git-maybe file*)
+  (define file (path->string file*))
+  (parameterize ([current-subprocess-custodian-mode 'kill])
+    (call-with-custodian-shutdown
+      (lambda ()
+        (define-values (proc stdout stdin stderr)
+          (subprocess
+            #f #f 'stdout
+            "/usr/bin/env"
+            "git"
+            "rev-parse"
+            "--show-toplevel"))
+        (port->string stdout)
+        (subprocess-wait proc)
+        (when (= 0 (subprocess-status proc))
+          (define-values (proc stdout stdin stderr)
+            (subprocess
+              #f #f 'stdout
+              "/usr/bin/env"
+              "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")
+
+    (with-nix-repl
+      (lambda ()
+        (define drv-def-out (nix-eval
+          (format "drv = with legacyPackages.${builtins.currentSystem}; instrumentedFetch (racketPackages.~a.src)" pkg-name)))
+        (nix-eval ":b drv")
+        (define build-log (nix-eval ":log drv"))
+        (match-define (list _ real-hash)
+          (regexp-match #px"FETCH_HASH:([^:]+):FETCH_HASH" build-log))
+        (define subpath (generate-spec real-hash))
+        (nix-eval ":r")
+        (nix-eval
+          (format "drv = with legacyPackages.${builtins.currentSystem}; instrumentedFetch (racketPackages.~a.src)" pkg-name))
+        (define out-path (nix-eval ":p drv.outPath"))
+        (nix-eval ":b drv")
+
+        (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 final nix file
+        (generate-spec real-hash version racket-launchers raco-commands #t)
+
+        (displayln "doing final module build")
+        (nix-eval ":r")
+        (nix-eval
+          (format ":b with legacyPackages.${builtins.currentSystem}; racketPackages.~a" pkg-name))))
+
+    (hash-set! acc pkg-name 'installed)
+
+    (void)))