|
@ -5,6 +5,8 @@ |
|
|
(require net/url) |
|
|
(require net/url) |
|
|
(require racket/string) |
|
|
(require racket/string) |
|
|
|
|
|
|
|
|
|
|
|
(define current-commits (make-parameter (list))) |
|
|
|
|
|
|
|
|
; Run a command and get the string written to stdout |
|
|
; Run a command and get the string written to stdout |
|
|
(define (system-result command) |
|
|
(define (system-result command) |
|
|
(match |
|
|
(match |
|
@ -16,14 +18,6 @@ |
|
|
(close-input-port errport) |
|
|
(close-input-port errport) |
|
|
result)])) |
|
|
result)])) |
|
|
|
|
|
|
|
|
(define posts (make-hash)) |
|
|
|
|
|
|
|
|
|
|
|
(define (store-post-id title post-id) |
|
|
|
|
|
(hash-set! posts title post-id)) |
|
|
|
|
|
|
|
|
|
|
|
(define (retrieve-post-id title) |
|
|
|
|
|
(hash-ref posts title)) |
|
|
|
|
|
|
|
|
|
|
|
; XML-RPC string |
|
|
; XML-RPC string |
|
|
(define (xstring str) |
|
|
(define (xstring str) |
|
|
`(value |
|
|
`(value |
|
@ -106,10 +100,6 @@ |
|
|
("post_content" |
|
|
("post_content" |
|
|
,(xstring post-content))))))) |
|
|
,(xstring post-content))))))) |
|
|
|
|
|
|
|
|
(define (is-new? title) |
|
|
|
|
|
(not |
|
|
|
|
|
(hash-has-key? posts title))) |
|
|
|
|
|
|
|
|
|
|
|
(define (get-post-id result) |
|
|
(define (get-post-id result) |
|
|
(se-path* '(string) |
|
|
(se-path* '(string) |
|
|
(string->xexpr |
|
|
(string->xexpr |
|
@ -120,7 +110,7 @@ |
|
|
(get-post-id |
|
|
(get-post-id |
|
|
(port->string |
|
|
(port->string |
|
|
(post-pure-port |
|
|
(post-pure-port |
|
|
(string->url "https://blog/xmlrpc.php") |
|
|
(string->url "https://primop.me/blog/xmlrpc.php") |
|
|
(string->bytes/utf-8 |
|
|
(string->bytes/utf-8 |
|
|
(xexpr->string |
|
|
(xexpr->string |
|
|
(cond |
|
|
(cond |
|
@ -160,16 +150,22 @@ |
|
|
(system-result "git rev-list master") |
|
|
(system-result "git rev-list master") |
|
|
"\n")) |
|
|
"\n")) |
|
|
|
|
|
|
|
|
|
|
|
(define (commit->post-id post-name) |
|
|
|
|
|
(compose1 |
|
|
|
|
|
string->number |
|
|
|
|
|
string-trim |
|
|
|
|
|
system-result |
|
|
|
|
|
(curry format "git notes --ref=~a show ~a" post-name))) |
|
|
|
|
|
|
|
|
(define (tracked? post-name) |
|
|
(define (tracked? post-name) |
|
|
|
|
|
(let ([get-post-id (commit->post-id post-name)]) |
|
|
|
|
|
(get-post-id |
|
|
(memf |
|
|
(memf |
|
|
number? |
|
|
get-post-id |
|
|
(map |
|
|
(current-commits))))) |
|
|
(compose1 string->number string-trim) |
|
|
|
|
|
(for/list ([commit (get-commits)]) |
|
|
(parameterize ([current-commits (get-commits)]) |
|
|
(system-result |
|
|
(for ([post (get-files)]) |
|
|
(format "git notes --ref=~a show ~a" post-name commit)))))) |
|
|
|
|
|
|
|
|
|
|
|
(for ([post (get-files)]) |
|
|
|
|
|
(match (tracked? post) |
|
|
(match (tracked? post) |
|
|
[#f (displayln "new post!") |
|
|
[#f (displayln "new post!") |
|
|
(let ([post-id (handle-post post #f)]) |
|
|
(let ([post-id (handle-post post #f)]) |
|
@ -180,4 +176,4 @@ |
|
|
(displayln (format "updating post ~a" post-id)) |
|
|
(displayln (format "updating post ~a" post-id)) |
|
|
(system (format |
|
|
(system (format |
|
|
"git notes --ref=~a add HEAD -fm \"~a\"" post post-id)) |
|
|
"git notes --ref=~a add HEAD -fm \"~a\"" post post-id)) |
|
|
(handle-post post post-id)])) |
|
|
(handle-post post post-id)]))) |
|
|