(define-module (env rust)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages curl)
  #:use-module (gnu packages certs)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages gcc)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages commencement)
  #:use-module (gnu packages compression)
  #:use-module (gnu system file-systems)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix utils)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix store)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (launch-rustup-environment
            init-rustup-environment))

(define rustup-origin
  (let ((name "rustup")
        (commit "737ad82333742dfd350a733c1649ce4e36109773")
        (version "1.26.0")
        (revision "0"))
    (origin
      (method git-fetch)
      (uri (git-reference
            (url "https://github.com/rust-lang/rustup")
            (commit commit)))
      (file-name (git-file-name name version))
      (sha256
       (base32 "1b9dcy5ckaqy119r311ds6zr7h5l4b1q52q88ls82zkk4109rpg4")))))

(define rustup-init-script-derivation
  (let ((file "rustup-init.sh"))
    (computed-file
     file
     (with-imported-modules '((guix build utils))
       #~(begin (use-modules (guix build utils))
                (let ((bin (string-append  #$output "/bin")))
                  (mkdir-p bin)
                  (symlink (string-append #$rustup-origin "/" #$file)
                           (string-append bin "/" #$file ))))))))

(define rustup-environment-manifest
  (manifest-add
   (packages->manifest
    (list glibc-for-fhs ;; has to be first
          (list (@@ (gnu packages gcc) gcc) "lib")
          gcc-toolchain
          coreutils
          curl
          grep
          nss-certs
          zlib)) ;; zlib is needed for rustc not for install
   (list
    (manifest-entry
      (name (origin-file-name rustup-origin))
      (version (substring (git-reference-commit
                           (origin-uri rustup-origin))
                          0 7))
      (item rustup-init-script-derivation)))))

(define* (exec-in-rustup-environment store launch cmd #:optional home)
  (let* ((mappings  (if home
                        (list
                         (file-system-mapping
                          (source home)
                          (target "/home/rustup")
                          (writable? #t)))
                        '())))
    (run-with-store store
      (mlet* %store-monad ((bash (package->derivation bash))
                           (profile (profile-derivation
                                     rustup-environment-manifest)))
        (mbegin %store-monad
          (built-derivations (list bash profile))
          (let ((bash-binary (string-append (derivation->output-path bash)
                                            "/bin/sh"))
                (profile-dir (derivation->output-path profile)))
            (launch #:command cmd
                    #:bash bash-binary
                    #:user "rustup"
                    #:user-mappings mappings
                    #:profile profile-dir
                    #:manifest rustup-environment-manifest
                    #:link-profile? #f
                    #:network? #t
                    #:map-cwd? #f
                    #:emulate-fhs? #t
                    #:nesting? #f)))))))

(define (call-with-guix-shell-hacks proc)
  "Overcome several pitfails calling launch-environment/container procedure we
aren't supposed to.  PROC is passed store connection and
launch-environment/container function."
  (let* ((_         (reload-module (resolve-module '(guix scripts environment))))
         (launch    (@@ (guix scripts environment) launch-environment/container))
         (setup-fhs (@@ (guix scripts environment) setup-fhs))
         (store     (open-connection))
         (tcgrp (tcgetpgrp (current-input-port))))
    ;; during launch-environment/container does at least one fork take place,
    ;; for some reason when child exits this process receives SIGTTOU and
    ;; SIGTTIN signals which put it to wait. Looks like a side-effect of hacks
    ;; inside script folder or linux-container module.
    (sigaction SIGTTOU SIG_IGN)
    (sigaction SIGTTIN SIG_IGN)
    (dynamic-wind
      (const #t)
      (λ ()
        (match (primitive-fork)
          (0
           (catch 'system-error
             (λ ()
               (proc store
                     ;; Curried launch function with setup-hook = setup-fhs
                     (λ args
                       (apply
                        launch (append args
                                       (list #:setup-hook setup-fhs))))))
             (λ args
               (format (current-error-port)
                       "error: ~a" (strerror (system-error-errno args))))))
          (pid (waitpid pid)
               ;; Again, maybe because of guix shell hacks or because of hacks
               ;; to make guix shell importable (eg ignoring signals) group ID
               ;; for the terminal used by input port changed after child
               ;; exits.  That causes input/output error when we jump back to
               ;; the prompt.
               (tcsetpgrp (current-input-port) tcgrp)
               ;; Why not?
               (flush-all-ports))))
      (λ () (close-connection store)))))

(define* (init-rustup-environment #:optional home)
  (call-with-guix-shell-hacks
   (λ (store launch)
     (exec-in-rustup-environment
      store launch'("rustup-init.sh" "-q" "-y") home))))

(define* (launch-rustup-environment #:optional home)
  (call-with-guix-shell-hacks
   (λ (store launch)
     (exec-in-rustup-environment
      store launch '("/bin/sh") home))))