#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)))