157 lines
5.1 KiB
Racket
157 lines
5.1 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/path
|
|
racket/string
|
|
racket/contract
|
|
racket/system
|
|
"config.rkt"
|
|
)
|
|
|
|
(provide git-exe
|
|
set-git-exe!
|
|
run-git
|
|
git-out
|
|
git-error
|
|
git-displ
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define cached-git-exe #f)
|
|
|
|
(define (ask-for-git-executable)
|
|
(displayln "Git was not found on PATH.")
|
|
(displayln "Enter the full path to git/git.exe, or press Enter to abort:")
|
|
(let loop ()
|
|
(display "> ")
|
|
(flush-output)
|
|
(let ((answer (read-line)))
|
|
(when (or (eof-object? answer)
|
|
(string=? (string-trim answer) ""))
|
|
(error 'git "Git executable not found; configuration aborted"))
|
|
(let ((candidate (find-executable-path answer)))
|
|
(if (eq? candidate #f)
|
|
(begin
|
|
(displayln
|
|
(format "'~a' is not found, please try again or press Enter to abort." answer))
|
|
(loop))
|
|
(begin
|
|
(set-git-exe! candidate)
|
|
#t)))))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/contract (git-exe)
|
|
(-> (or/c path? #f))
|
|
(if (eq? cached-git-exe #f)
|
|
(let ((the-git-exe (let ((exe (cfg-get 'git 'exe #f)))
|
|
(if (eq? exe #f)
|
|
(let ((path (find-executable-path "git")))
|
|
(if (eq? path #f)
|
|
(if (ask-for-git-executable)
|
|
(git-exe)
|
|
#f)
|
|
path))
|
|
exe
|
|
))))
|
|
(set! cached-git-exe the-git-exe)
|
|
the-git-exe)
|
|
cached-git-exe))
|
|
|
|
(define/contract (set-git-exe! exe-path)
|
|
(-> path? void?)
|
|
(void
|
|
(begin
|
|
(cfg-set! 'git 'exe exe-path)
|
|
(set! cached-git-exe exe-path))))
|
|
|
|
|
|
(define/contract (run-git args)
|
|
(-> (listof (or/c path-string? symbol?))
|
|
(listof (list/c (one-of/c 'stdout 'stderr) string?)))
|
|
(let-values (((process stdout stdin stderr)
|
|
(apply subprocess
|
|
#f
|
|
#f
|
|
#f
|
|
(git-exe)
|
|
(map (lambda (arg)
|
|
(if (symbol? arg)
|
|
(symbol->string arg)
|
|
arg))
|
|
args))))
|
|
(close-output-port stdin)
|
|
(let ((output-channel (make-channel)))
|
|
(define (read-output source port)
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ((line (read-line port)))
|
|
(channel-put output-channel (list source line))
|
|
(if (eof-object? line)
|
|
(close-input-port port)
|
|
(loop)))))))
|
|
|
|
(read-output 'stdout stdout)
|
|
(read-output 'stderr stderr)
|
|
|
|
(let loop ((open-ports 2)
|
|
(result '()))
|
|
(if (= open-ports 0)
|
|
(begin
|
|
(subprocess-wait process)
|
|
(reverse result))
|
|
(let* ((output (channel-get output-channel))
|
|
(line (cadr output)))
|
|
(if (eof-object? line)
|
|
(loop (- open-ports 1) result)
|
|
(loop open-ports
|
|
(cons output result)))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided utility functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (is-output? e)
|
|
(or (eq? (car e) 'stdout)
|
|
(and (eq? (car e) 'stderr)
|
|
(string-prefix? (string-downcase (cadr e)) "warning:"))))
|
|
|
|
(define (is-error? e)
|
|
(not (is-output? e)))
|
|
|
|
(define (git-out cmd output)
|
|
(let* ((out (map (λ (e) (cadr e)) (filter (λ (e) (is-output? e)) output)))
|
|
(err (map (λ (e) (cadr e)) (filter (λ (e) (is-error? e)) output)))
|
|
(r (null? err))
|
|
)
|
|
(values r (if (eq? r #t) out err))))
|
|
|
|
(define-syntax git-error
|
|
(syntax-rules ()
|
|
((_ cmd msg* out)
|
|
(let ((msg (format "git ~a: ~a: ~a" cmd msg* (string-join
|
|
(map (λ (e) (format "~a" e))
|
|
(if (list? out)
|
|
out
|
|
(list out)))
|
|
"\n"))))
|
|
(err-git msg)
|
|
(error 'git msg))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (git-displ out)
|
|
(let ((str (if (string? out) out (string-join out "\n"))))
|
|
(unless (string=? (string-trim str) "")
|
|
(info-git str)
|
|
(when (cfg-get 'git 'display-output #t)
|
|
(displayln str)))))
|