|
@ -33,6 +33,8 @@ |
|
|
(hash-set! config 'password password)] |
|
|
(hash-set! config 'password password)] |
|
|
[(list "username" username) |
|
|
[(list "username" username) |
|
|
(hash-set! config 'username username)] |
|
|
(hash-set! config 'username username)] |
|
|
|
|
|
[(list "url" url) |
|
|
|
|
|
(hash-set! config 'url url)] |
|
|
[val (error |
|
|
[val (error |
|
|
(format "Invalid configuration line: ~a" val))])) |
|
|
(format "Invalid configuration line: ~a" val))])) |
|
|
(curry hash-ref config)))) |
|
|
(curry hash-ref config)))) |
|
@ -48,11 +50,14 @@ |
|
|
(match |
|
|
(match |
|
|
(process command) |
|
|
(process command) |
|
|
[(list out in pid errport _) |
|
|
[(list out in pid errport _) |
|
|
(let ([result (port->string out)]) |
|
|
(let ([result (port->string out)] |
|
|
|
|
|
[err-result (port->string out)]) |
|
|
(close-input-port out) |
|
|
(close-input-port out) |
|
|
(close-output-port in) |
|
|
(close-output-port in) |
|
|
(close-input-port errport) |
|
|
(close-input-port errport) |
|
|
result)])) |
|
|
(cond |
|
|
|
|
|
[(not (string=? "" (string-trim result))) result] |
|
|
|
|
|
[else #f]))])) |
|
|
|
|
|
|
|
|
; XML-RPC string |
|
|
; XML-RPC string |
|
|
(define (xstring str) |
|
|
(define (xstring str) |
|
@ -146,7 +151,7 @@ |
|
|
(get-post-id |
|
|
(get-post-id |
|
|
(port->string |
|
|
(port->string |
|
|
(post-pure-port |
|
|
(post-pure-port |
|
|
(string->url "https://primop.me/blog/xmlrpc.php") |
|
|
(string->url (your-config 'url)) |
|
|
(string->bytes/utf-8 |
|
|
(string->bytes/utf-8 |
|
|
(xexpr->string |
|
|
(xexpr->string |
|
|
(cond |
|
|
(cond |
|
@ -184,48 +189,86 @@ |
|
|
; Get a list of all commit refs |
|
|
; Get a list of all commit refs |
|
|
(define (get-commits) |
|
|
(define (get-commits) |
|
|
(string-split |
|
|
(string-split |
|
|
(system-result "git rev-list master") |
|
|
(match (system-result "git rev-list master") |
|
|
|
|
|
[#f ""] |
|
|
|
|
|
[str str]) |
|
|
"\n")) |
|
|
"\n")) |
|
|
|
|
|
|
|
|
; Convert a commit ref into its post ID number (if it exists) |
|
|
; Convert a commit ref into its post ID number (if it exists) |
|
|
(define (commit->post-id post-name) |
|
|
(define (commit->post-id post-name commit-ref) |
|
|
(compose1 |
|
|
(string->number |
|
|
string->number |
|
|
(string-trim |
|
|
string-trim |
|
|
(system-result |
|
|
system-result |
|
|
(format "git notes --ref=~a show ~a" post-name commit-ref))))) |
|
|
(curry format "git notes --ref=~a show ~a" post-name))) |
|
|
|
|
|
|
|
|
(define (git-notes-ref post-name commit-ref) |
|
|
|
|
|
(let ([result |
|
|
|
|
|
(string-trim |
|
|
|
|
|
(match |
|
|
|
|
|
(system-result |
|
|
|
|
|
(format "git notes --ref=~a show ~a" |
|
|
|
|
|
post-name |
|
|
|
|
|
commit-ref)) |
|
|
|
|
|
[#f ""] |
|
|
|
|
|
[str str])) |
|
|
|
|
|
|
|
|
|
|
|
]) |
|
|
|
|
|
(displayln (format "git notes ref result: ~a" result)) |
|
|
|
|
|
result)) |
|
|
|
|
|
|
|
|
; Grab a post id given a post name |
|
|
; Grab a post id given a post name |
|
|
; Return false if it does not exist |
|
|
; Return false if it does not exist |
|
|
(define (git-href post-name) |
|
|
(define git-href |
|
|
(let ([convert-commit (commit->post-id post-name)]) |
|
|
(let ([def-val (gensym)]) |
|
|
(displayln (map convert-commit (current-commits))) |
|
|
(lambda (post-name [default def-val]) |
|
|
(match |
|
|
(match |
|
|
(memf |
|
|
(memf |
|
|
convert-commit |
|
|
(lambda (commit-ref) |
|
|
|
|
|
(displayln (format "checking commit ~a" commit-ref)) |
|
|
|
|
|
(let ([notes (git-notes-ref post-name commit-ref)]) |
|
|
|
|
|
(match notes |
|
|
|
|
|
["" (displayln (format "commit ~a did not have anything" commit-ref)) #f] |
|
|
|
|
|
[result (displayln (format "found ~a in commit ~a" result commit-ref)) #t]))) |
|
|
(current-commits)) |
|
|
(current-commits)) |
|
|
[(list-rest post-id _) |
|
|
[(list-rest commit-id _) commit-id] |
|
|
(convert-commit post-id)] |
|
|
[_ |
|
|
[x #f]))) |
|
|
(cond |
|
|
|
|
|
[(eq? def-val default) |
|
|
|
|
|
(raise |
|
|
|
|
|
(exn:fail |
|
|
|
|
|
(format |
|
|
|
|
|
"git-href: no value found for key\n\t~a" post-name) |
|
|
|
|
|
(current-continuation-marks)))] |
|
|
|
|
|
[else default])])))) |
|
|
|
|
|
|
|
|
; Add or refresh a post id associated with that post name |
|
|
; Add or refresh a post id associated with that post name |
|
|
(define (git-set! post-name post-id) |
|
|
(define (git-set! post-name post-id) |
|
|
(displayln (format "git setting ~a ~a" post-name post-id)) |
|
|
;(displayln (format "git setting ~a ~a" post-name post-id)) |
|
|
(system |
|
|
(system |
|
|
(format |
|
|
(format |
|
|
"git notes --ref=~a add HEAD -fm \"~a\"" |
|
|
"git notes --ref=~a add HEAD -fm \"~a\"" |
|
|
post-name |
|
|
post-name |
|
|
post-id))) |
|
|
post-id))) |
|
|
|
|
|
|
|
|
(parameterize ([current-commits (get-commits)]) |
|
|
(parameterize ([current-commits (get-commits)]) |
|
|
|
|
|
(displayln (format "these are the current commits: ~a" (current-commits))) |
|
|
(for ([post (get-files)]) |
|
|
(for ([post (get-files)]) |
|
|
(match (git-href post) |
|
|
;(call-with-values (lambda () (split-path (string->path post))) (compose1 displayln list)) |
|
|
|
|
|
(match (git-href post #f) |
|
|
[#f (displayln "new post!") |
|
|
[#f (displayln "new post!") |
|
|
|
|
|
|
|
|
(when (empty? (current-commits)) |
|
|
(when (empty? (current-commits)) |
|
|
|
|
|
; Add a first commit if there are none so it can store the note properly! |
|
|
(system "git commit -n --allow-empty -m \"bootstrap blog\"")) |
|
|
(system "git commit -n --allow-empty -m \"bootstrap blog\"")) |
|
|
(let ([post-id (handle-post post #f)]) |
|
|
|
|
|
(git-set! post post-id))] |
|
|
(git-set! post (handle-post post #f))] |
|
|
[post-id |
|
|
|
|
|
(displayln (format "updating post ~a" post-id)) |
|
|
[commit-id |
|
|
|
|
|
(displayln (format "updating post ~a" post)) |
|
|
|
|
|
(displayln (format "the commit ref I got is ~a" commit-id)) |
|
|
|
|
|
(let ([post-id (commit->post-id post commit-id)]) |
|
|
|
|
|
(displayln post-id) |
|
|
|
|
|
(displayln (format "the commit ref is ~a" commit-id)) |
|
|
(git-set! post post-id) |
|
|
(git-set! post post-id) |
|
|
(handle-post post post-id)]))) |
|
|
(handle-post post post-id))]))) |
|
|
|
|
|
|
|
|