A simple, single branch, version control system for individuals
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

389 lines
13 KiB

#! /usr/bin/env slope
;;;
;;; Entry point for `solo`
;;;
(define solo-print-help (lambda ()
(display-lines
"usage: solo [[command]] [[args]]" ""
"Commands:" ""
"\tinit"
"\t\tinitialize the current directory as a solo repository"
"\tcommit [message]"
"\t\tback up the current work tree and saving it with the given commit message"
"\ttag [[commit] [tag-name]]"
"\t\ttags a given commit with the given tag name; if no arguments are passed the available tags will be listed; tags can be recalled with `use`"
"\tstatus"
"\t\treports what files have been added, have been deleted, and have changed"
"\tdiff"
"\t\tshows what has changed in what files between the current tree and HEAD"
"\tpick [commit] [file] [[to-file]]"
"\t\tcopies the given file from the given commit into the current workspace (clobbers); if `to-file` is given then file will be stored to the given to-file path"
"\tuse [[commit|tag-name]]"
"\t\tchanges the current workspace to the state of the given commit or tag name; if no commit is given HEAD will be used; be sure to commit any unsaved work you want to keep before use"
)))
;;;
;;; Entry point for `solo init`
;;;
(define solo-init (lambda ()
(if (solo-is-repo? #t)
(begin
(write "A solo repository has already been initialized in this directory" stderr)
(exit 1)))
(define name (path-base (pwd)))
(define solo-root (path-join (pwd) ".solo"))
(if (path-exists? solo-root)
(begin
(write "The current directory is already a solo repository\n" stderr)
(exit 1)))
(mkdir solo-root 0775)
(chdir solo-root)
(close (file-create "HEADS"))
(mkdir "snapshots" 0775)
(mkdir "refs" 0775)
(mkdir "refs/tags" 0775)))
;;;
;;; Entry point to `solo log`
(define solo-view-log (lambda ()
(solo-is-repo? #f)
(define buf (string-make-buf))
(define num 0)
(define loop (lambda (id)
(define p (path-join (pwd) ".solo" "snapshots" id ".commit"))
(define data #f)
(define txt (if (path-exists? p) (open-read-close p) #f))
(if txt (set! data (eval txt #t)))
(define parent "")
(define panic-mode? (exception-mode-panic?))
(if (pair? data)
(begin
(if panic-mode? (exception-mode-pass))
(write (append "ID : " (assoc data "id") "\n") buf)
(write (append "Time : " (assoc data "time") "\n") buf)
(write (append "User : " (assoc data "name") "\n") buf)
(write (append "Msg : " (assoc data "message") "\n") buf)
(write ".\n" buf)
(set! parent (assoc data "parent"))))
(if (and (~bool parent) (string? parent))
(begin0
(loop parent)
(if panic-mode? (exception-mode-panic)))
(if panic-mode? (exception-mode-panic)))))
(loop (solo-get-head))
(define tmpfile (file-create-temp "solo-log"))
(if tmpfile
(begin
(write (read-all buf) tmpfile)
(close tmpfile)
(subprocess [(if (not (equal? (env "PAGER") "")) (env "PAGER") "less") (file-name tmpfile)]))
(write (read-all buf) stdout))))
;;;
;;; Entry point to `solo pick`
;;;
(define solo-pick (lambda ()
(solo-is-repo? #f)
(if (< (length sys-args) 4)
(begin
(write "'solo pick' expected a commit id and a file, with an optional argument specifying a new filename to write to, insufficient arguments were given\n" stderr)
(exit 1)))
(define commit (ref sys-args 2))
(if (equal? (string-lower commit) "head")
(set! commit (solo-get-head)))
(define file (slice (path-abs (ref sys-args 3)) (+ (length (pwd)) 1)))
(define from-path (path-join (pwd) ".solo" "snapshots" commit file))
(if (not (path-exists? from-path))
(begin
(write (string-format "%v could not be found within %v\n" file commit) stderr)
(exit 1)))
(define from-file (file-open-read from-path))
(if from-file
(begin
(if (> (length sys-args) 4)
(set! file (path-abs (ref sys-args 4)))
(set! (path-join (pwd) file)))
(define to-file (file-create file))
(if to-file
(begin
(write (read-all from-file) to-file)
(close to-file)
(close from-file))
(write (string-format "Could not write to HEAD file %v\n" (path-join (pwd) file)) stderr)))
(begin
(write (string-format "Could not open %v to do pick operation\n" from-path) stderr)
(exit 1)))))
;;;
;;; Entry point to `solo status`
;;;
(define solo-status (lambda ()
(solo-is-repo? #f)
(define out (solo-files-changed devnull (solo-get-head)))
(apply display-lines (map (lambda (p) (append "\033[32m Added: \033[0m" (car (cdr p)))) (filter (lambda (p) (equal? (car p) "+")) out)))
(apply display-lines (map (lambda (p) (append "\033[31mDeleted: \033[0m" (car (cdr p)))) (filter (lambda (p) (equal? (car p) "-")) out)))
(apply display-lines (map (lambda (p) (append "\033[33mChanged: \033[0m" (car (cdr p)))) (filter (lambda (p) (equal? (car p) "~")) out)))
(define changed (length (filter (lambda (p) (not (equal? (car p) "."))) out)))
(if (equal? changed 0)
(write "There are no uncommitted changes\n" stderr))))
;;;
;;; Entry point to `solo diff`
;;;
(define solo-diff (lambda ()
(solo-is-repo? #f)
(solo-files-changed stdout (solo-get-head))))
;;;
;;; Entry point to `solo commit`
;;;
(define solo-make-snapshot (lambda (msg)
(solo-is-repo? #f)
(define repo-root (pwd))
(define solo-root (path-join repo-root ".solo"))
;; Get metadata
(define username (string-make-buf))
(if (not (equal? (subprocess ["id" "-u" "-n"] username devnull) 0))
(begin
(string-buf-clear)
(write (env "USER") username)))
(define write-time (date))
(define id (string->md5 (append write-time username msg)))
;; Make the commit dir
(define commit-dir (path-join
solo-root
"snapshots"
id))
(mkdir commit-dir 0755)
;; Write commit file
(if (define commit-file (file-create (path-join commit-dir ".commit")))
(begin
(write
[
["name" (append (string-trim-space (read-all username)) "@" (hostname))]
["time" write-time]
["message" msg]
["id" id]
["parent" (solo-update-head solo-root id)]]
commit-file)
(close commit-file)))
;; Copy files to snapshot
(for-each
(lambda (p)
(if (path-is-dir? p)
(mkdir (path-join commit-dir (regex-replace repo-root p "")) 0755 #t)
(solo-copy-file p (regex-replace repo-root p commit-dir))))
(solo-get-filepath-list repo-root))))
;;;
;;; Entry point for `solo use`
;;;
(define solo-use (lambda ()
(solo-is-repo? #f)
(define commit (if (> (length sys-args) 2) (ref sys-args 2) (solo-get-head)))
;; Handle a tag being passed
(if (path-exists? (path-join (pwd) ".solo" "refs" "tags" commit))
(begin
(define tagval (open-read-close (path-join (pwd) ".solo" "refs" "tags" commit)))
(if tagval (set! commit tagval))))
;; Vet the commit
(set! commit (path-join (pwd) ".solo" "snapshots" commit))
(if (not (path-exists? commit))
(begin
(write "The given commit does not exist\n" stderr)
(exit 1)))
;; Replace the files in root with commit files
(for-each
(lambda (p)
(if (path-is-dir? p)
(mkdir p 0755 #t)
(if (not (equal? (path-base ".commit") p))
(solo-copy-file p (regex-replace commit p (pwd))))))
(path-glob (path-join commit "**")))))
;;;
;;; Entry point for `solo tag`
;;;
(define solo-tag (lambda ()
(solo-is-repo? #f)
(define commit #f)
(define tag #f)
(if (equal? (length sys-args) 2)
(begin
(apply display-lines (map (lambda (ln)
(path-base ln)) (path-glob (path-join (pwd) ".solo" "refs" "tags" "*"))))
(exit 1)))
(if (< (length sys-args) 4)
(begin
(write "A commit and a tag name are both required\n" stderr)
(exit 1)))
(set! commit (ref sys-args 2))
(if (not (path-exists? (path-join (pwd) ".solo" "snapshots" commit ".commit")))
(begin
(write "The commit passed to 'tag' does not exist\n" stderr)
(exit 1)))
(set! tag (string-trim-space (ref sys-args 3)))
(if (not (~bool tag))
(begin
(write "The tag name passed to 'tag' must be at least one non-whitespace character long\n" stderr)
(exit 1)))
(define new-tag-path (path-join (pwd) ".solo" "refs" "tags" tag))
(if (path-exists? new-tag-path)
(begin
(write "The tag name passed to 'tag' already exists. Please select a unique identifier\n" stderr)
(exit 1)))
(define f (file-create new-tag-path))
(if f
(close (write commit f))
(write "An error occured writing the tag to disk\n" stderr))))
;; -------------------------------------
;; ------------------8<-----------------
;; -------------------------------------
(define solo-main (lambda ()
(cond
((equal? (length sys-args) 1) (solo-print-help))
((equal? (car (cdr sys-args)) "init" ) (solo-init) )
((equal? (car (cdr sys-args)) "use" ) (solo-use) )
((equal? (car (cdr sys-args)) "status") (solo-status) )
((equal? (car (cdr sys-args)) "diff" ) (solo-diff) )
((equal? (car (cdr sys-args)) "pick" ) (solo-pick) )
((equal? (car (cdr sys-args)) "tag" ) (solo-tag) )
((equal? (car (cdr sys-args)) "log" ) (solo-view-log))
((equal? (car (cdr sys-args)) "commit")
(solo-make-snapshot (if (> (length sys-args) 2) (ref sys-args 2) "")))
(else (solo-print-help)))))
(define solo-get-filepath-list (lambda (root-dir)
(define out [])
(define ignore (solo-get-ignored))
(for-each (lambda (p)
(if (and (not (path-is-dir? p)) (not (member? ignore p)) (not (regex-match? "\\.solo[^i]" p)))
(set! out (append out p))))
(path-glob (path-join root-dir "**")))
out))
(define solo-is-repo? (lambda (return?)
(define solo-root (path-join (pwd) ".solo"))
(if
(not (and
(path-exists? solo-root)
(path-exists? (path-join solo-root "HEADS"))
(path-exists? (path-join solo-root "snapshots"))))
(if return?
#f
(begin
(write "The current directory is not a solo repository root\n" stderr)
(exit 1)))
#t)))
(define solo-files-changed (lambda (output ...)
(define first-path #f)
(define second-path (pwd))
(define homedir #t)
(cond
((null? ...) (! "'solo-changed-files' expects at least one commit to compare against"))
((equal? 1 (length ...)) (set! first-path (path-join (pwd) ".solo" "snapshots" (car ...))))
((> (length ...) 1)
(begin
(set! homedir #f)
(set! first-path (path-join (pwd) ".solo" "snapshots" (car ...)))
(set! second-path (path-join (pwd) ".solo" "snapshots" (car (cdr ...)))))))
(define ignored (solo-get-ignored))
(if homedir
(set! ignored (map (lambda (ln) (slice ln (+ (length (pwd)) 1))) ignored))
(set! ignored []))
(define first-list (filter (lambda (p) (not (equal? (path-base p) ".commit"))) (path-glob (path-join first-path "**"))))
(set! first-list (map (lambda (p) (slice p (+ (length first-path) 1))) first-list))
(define second-list (map (lambda (p) (slice p (+ (length second-path) 1))) (path-glob (path-join second-path "**"))))
(set! second-list (filter (lambda (p) (not (or (equal? (slice p 0 6) ".solo/") (member? ignored p) (equal? p "") (equal? p ".commit")))) second-list))
(define out (map (lambda (p)
(cond
((path-is-dir? (path-join second-path p)) ["." p])
((not (member? first-list p)) ["+" p])
(else (begin
(define status (solo-do-diff (path-join first-path p) (path-join second-path p) output))
(cond
((equal? status 0) ["." p])
((equal? status 1) ["~" p])
((equal? status 2) ["-" p])))))) second-list))
(for-each
(lambda (p)
(if (and (not (member? second-list p)) (not (equal? "" (string-trim-space p))))
(set! out (append out ["-" p]))))
first-list)
out))
(define solo-do-diff (lambda (fileone filetwo file-out)
(subprocess ["diff" "-u" "-b" "-B" "--color=always" fileone filetwo] file-out devnull)))
(define solo-copy-file (lambda (from to)
(define in (file-open-read from))
(mkdir (path-dir (path-abs to)) 0775 #t)
(define out (file-create to))
(if (and in out)
(begin
(write (read-all in) out)
(close in)
(close out)))))
(define solo-get-head (lambda ()
(define f (file-open-read (path-join (pwd) ".solo" "HEADS")))
(if f
(begin0
(string-trim-space (read-all f))
(close f))
"")))
;; Updates head to the new hash and returns the old one
(define solo-update-head (lambda (solo-root new-commit-hash)
(define head-path (path-join solo-root "HEADS"))
(define parent-hash (solo-get-head))
(close (write new-commit-hash (file-create head-path)))
parent-hash))
(define solo-get-ignored (lambda ()
(if (path-exists? (path-join (pwd) ".soloignore"))
(begin
(define files (string->list (open-read-close (path-join (pwd) ".soloignore")) "\n"))
(define out [])
(for-each (lambda (ln) (set! out (list-join out (path-glob (path-abs ln))))) (filter (lambda (l) (~bool l)) files))
out)
[])))
(define open-read-close (lambda (path)
(define f (file-open-read path))
(if f
(begin0
(read-all f)
(close f))
#f)))
;;; RUN IT!
(solo-main)
; vim: ts=2 sw=2 expandtab ft=slope