First setup with git cli utility

.gitignore

@@ -2,6 +2,7 @@
 /doc
 /scribblings/compiled
 /tests/compiled
+/private/compiled
 
 /docs
 *~

info.rkt

@@ -2,13 +2,13 @@
 
 (define collection "git-cli")
 (define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
-(define version "0.3.1")
+(define version "0.3.5")
 (define pkg-authors '("Hans Dijkema"))
 (define license 'MIT)
 
 (define deps
   '("base"
-    ("simple-ini" #:version "0.3.3")
+    ("simple-ini")
     "racket-index"
     "scribble-lib"
     "racket-makefile"

main.rkt

@@ -1 +1,26 @@
 #lang racket/base
+
+(require "private/git-provider.rkt"
+         "private/git-commands.rkt"
+         "private/config.rkt"
+         )
+
+(provide git)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Provided commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (git command . args)
+  (cond
+    ([eq? command 'status] (cmd-git-status args))
+    ([eq? command 'add] (cmd-git-add args))
+    (else (error "Not supported git command '~a" command))
+    )
+  )
+
+(define (git-status . args)
+  (cmd-git-status args))
+
+(define (git-add . args)
+  (cmd-git-add args))

private/config.rkt

@@ -0,0 +1,55 @@
+#lang racket/base
+
+(require simple-ini/class
+         simple-log
+         )
+
+(provide cfg-get
+         cfg-set!
+         dbg-git
+         info-git
+         err-git
+         warn-git
+         fatal-git
+         sync-log-git
+         )
+
+(sl-def-log git)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Internal state / functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define ini #f)
+
+(define (check-ini)
+  (when (eq? ini #f)
+    (set! ini (new ini% [file 'git-cli]))))
+
+(define mutex (make-semaphore 1))
+
+(define-syntax critical
+  (syntax-rules ()
+    ((_ b1 ...)
+     (dynamic-wind
+      (λ () (semaphore-wait mutex))
+      (λ () b1 ...)
+      (λ () (semaphore-post mutex)))
+     )
+    )
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Provided functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (cfg-set! section key value)
+  (critical
+   (check-ini)
+   (send ini set! section key value)))
+
+(define (cfg-get section key default-value)
+  (critical
+   (check-ini)
+   (send ini get section key default-value)))
+

private/git-commands.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+
+(require "git-provider.rkt"
+         racket/string
+         
+         )
+
+(provide cmd-git-status
+         cmd-git-add
+         )
+
+(define (cmd-git-status args)
+  (let ((output (run-git '(status -s))))
+    (let-values (((result out) (git-out 'status output)))
+      (if result
+          (map (λ (line)
+                 (let* ((state (string->symbol (string-trim (substring line 0 2))))
+                        (file (string-trim (substring line 3))))
+                   (cond
+                     ([eq? state '??] (list 'new file))
+                     ([eq? state 'M] (list 'modified file))
+                     ([eq? state 'A] (list 'added file))
+                     ([eq? state 'D] (list 'deleted file))
+                     ([eq? state 'AM] (list 'modified-added file))
+                     ([eq? state 'AD] (list 'deleted-added file))
+                     (else
+                      (git-error 'status "Unexpected state" state))
+                     )
+                   ))
+               out)
+          (git-error 'status "Error" out)
+          )
+      )
+    )
+  )
+
+(define (cmd-git-add args)
+  (let ((output (run-git (cons 'add args))))
+    (let-values (((result out) (git-out 'add output)))
+      (if result
+          (begin
+            (git-displ out)
+            result)
+          (git-error 'add "Error" out)))))
+  

private/git-provider.rkt

@@ -0,0 +1,155 @@
+#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"))))
+    (info-git str)
+    (when (cfg-get 'git 'display-output #t)
+      (displayln str))))

private/utils.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+
+(provide config)
+