397 lines
15 KiB
Racket
397 lines
15 KiB
Racket
#lang cli
|
|
|
|
(require (only-in racket/date current-date date->string date-display-format)
|
|
(only-in racket/string string-join string-split non-empty-string?)
|
|
(only-in racket/list first second third fourth fifth last take drop flatten add-between)
|
|
(only-in racket/format ~a)
|
|
(only-in racket/exn exn->string)
|
|
(only-in racket/function thunk identity)
|
|
(only-in csv-reading csv->list)
|
|
(only-in xml read-xml)
|
|
(only-in "./utils.rkt" list->csv resource-link atom-table-entry add-atom-entry
|
|
make-feed archive-file git-forge source-url))
|
|
|
|
(define-namespace-anchor anc)
|
|
(define ns (namespace-anchor->namespace anc))
|
|
|
|
|
|
;; modify needs to
|
|
|
|
;: - take an input file (from archive/), build a source file in the appropriate place in source/
|
|
|
|
;; - update the line for the resource in the read-table for resource type, adding the modified date
|
|
;; this will not! (for now) update the <resource>/index or tagged/<tag>/index pages !
|
|
;; (these pages do not currently show post history)
|
|
|
|
;; - update the atom table and rebuild the atom feed
|
|
|
|
;; example
|
|
;; modify -input-file in-progress/beginning-latl.scm --resource-type unsettled
|
|
;; --headline "Beginning LATL"
|
|
;; publish -i in-progress/beginning-latl.scm -r unsettled -l "Beginning LATL"
|
|
|
|
(help (usage "modify is here to update existing posts with new content."))
|
|
|
|
|
|
(flag (resource-type #:param [resource-type ""] t)
|
|
("-r" "--resource-type" "Type of resource [settled|unsettled|root]")
|
|
(resource-type (cond
|
|
[(equal? t "settled") "settled"]
|
|
[(equal? t "unsettled") "unsettled"]
|
|
[(equal? t "root") "root"]
|
|
[else (error 'failure "couldn't recognize resource. please use one of 'settled' 'unsettled' 'root'")])))
|
|
|
|
(flag (input #:param [input ""] i)
|
|
("-i" "--input-file" "file to publish")
|
|
(input (if (file-exists? i)
|
|
i
|
|
(error 'failure "couldn't locate file ~a" i))))
|
|
|
|
(flag (headline #:param [headline ""] h)
|
|
("-l" "--headline" "the shortest representation of a post")
|
|
(headline (if (non-empty-string? h)
|
|
h
|
|
(error 'failure "your post needs a headline"))))
|
|
|
|
(flag (test-mode)
|
|
("-x" "--test-mode" "updates only in test directory")
|
|
(test-mode #t))
|
|
|
|
(program
|
|
(modify)
|
|
(let ([n-in (input)]
|
|
[r-type (resource-type)]
|
|
[l-head (headline)]
|
|
[x-test (test-mode)]
|
|
[update-time (date->string (current-date) (date-display-format 'iso-8601))]
|
|
[rollback-thunks (list)])
|
|
(displayln "running modify")
|
|
|
|
|
|
;; getting existing file ports
|
|
;; ---------------------------
|
|
;; if any of these fail to match, exit modify
|
|
;; must use #:exists 'update
|
|
;; this throws an exception if the file does not exist, but it must be manually
|
|
;; truncated. using #:exists 'must-truncate guarantees file exists, but truncates
|
|
;; prior to data being read from file
|
|
|
|
;; locate existing post in source
|
|
;; (. -> . input-port? output-port?)
|
|
(define (get-source-ports)
|
|
(let*
|
|
([file-id (last (string-split n-in "/"))]
|
|
[file-handle (if (equal? r-type "root")
|
|
(if x-test
|
|
(build-path "publish-test" "source" file-id)
|
|
(build-path "source" file-id))
|
|
(if x-test
|
|
(build-path "publish-test" "source" r-type file-id)
|
|
(build-path "source" r-type file-id)))])
|
|
(values
|
|
(open-input-file file-handle)
|
|
(open-output-file file-handle #:exists 'update))))
|
|
|
|
;; locate data/resource table
|
|
;; (. -> . input-port? output-port?)
|
|
(define (get-res-table-ports)
|
|
(let ([file-handle (path-add-extension
|
|
(if x-test
|
|
(build-path "publish-test" "data" r-type)
|
|
(build-path "data" r-type))
|
|
#".csv")])
|
|
(values
|
|
(open-input-file file-handle)
|
|
(open-output-file file-handle #:exists 'update))))
|
|
|
|
;; locate data/atom table
|
|
;; (. -> . input-port? output-port?)
|
|
(define (get-atom-table-ports)
|
|
(let ([file-handle (path-add-extension
|
|
(if x-test
|
|
(build-path "publish-test" "data" "atom")
|
|
(build-path "data" "atom"))
|
|
#".csv")])
|
|
(values
|
|
(open-input-file file-handle)
|
|
(open-output-file file-handle #:exists 'update))))
|
|
|
|
;; locate source/feed.atom feed
|
|
;; (. -> . input-port? output-port?)
|
|
(define (get-atom-feed-ports)
|
|
(let ([file-handle (path-add-extension
|
|
(if x-test
|
|
(build-path "publish-test" "source" "feed")
|
|
(build-path "source" "feed"))
|
|
#".atom")])
|
|
(values
|
|
(open-input-file file-handle)
|
|
(open-output-file file-handle #:exists 'update))))
|
|
|
|
;; get make-atom.scm input-port
|
|
;; (. -> . input-port?)
|
|
(define (get-make-atom-input-port)
|
|
(let ([file-handle (path-add-extension
|
|
(if x-test
|
|
(build-path "publish-test" "data" "make-atom")
|
|
(build-path "data" "make-atom"))
|
|
#".scm")])
|
|
(open-input-file file-handle)))
|
|
|
|
|
|
(define (handle-error-getting-file expn)
|
|
(displayln "handle-error-getting-file")
|
|
(displayln expn)
|
|
(raise expn))
|
|
;; ---------------------------
|
|
|
|
;; other let-bindings expressions
|
|
;; ------------------------------
|
|
(define (get-res-table-and-id res-table-input-port)
|
|
(let ([res-table (csv->list res-table-input-port)])
|
|
(values
|
|
res-table
|
|
(first
|
|
;; need to handle errors
|
|
(findf
|
|
(lambda (row)
|
|
(equal? (second row)
|
|
l-head))
|
|
res-table)))))
|
|
|
|
|
|
(define (get-tags type id)
|
|
(let* ([tag-file-handle (path-add-extension
|
|
(if x-test
|
|
(build-path "publish-test" "data" "tagged")
|
|
(build-path "data" "tagged"))
|
|
#".csv")]
|
|
[tag-table (csv->list (open-input-file tag-file-handle))]
|
|
;; id in tagged.csv is <res>/<id>
|
|
[match-id (string-append type "/" id)])
|
|
(map
|
|
first
|
|
(filter
|
|
(lambda (tag-row)
|
|
(member match-id tag-row))
|
|
tag-table))))
|
|
|
|
;; ------------------------------
|
|
|
|
;; rollback execution
|
|
;; ------------------
|
|
;; all handlers of any exception raised after writes start occurring must evaluate
|
|
;; all rollback thunks registered up to the point of exception to ensure the
|
|
;; file system returns to its pre-script execution state. this is written to handle
|
|
;; any exceptions raised in rollback thunks and retry indefinitely. if there is an
|
|
;; unresolvable issue, the script will need to be manually exited and the resulting
|
|
;; mess cleaned up.
|
|
(define (rollback-exec rb-thunks)
|
|
(for-each
|
|
(lambda (th)
|
|
(call-with-exception-handler
|
|
(lambda (expn)
|
|
(displayln (~a "encountered error" (exn->string expn)))
|
|
(displayln (~a "running " th " again"))
|
|
(th)))
|
|
th)
|
|
rb-thunks))
|
|
;; ------------------
|
|
|
|
;; file-writing
|
|
;; ------------
|
|
;; generic file writing and exceptions
|
|
(struct file-write-exception exn:fail:filesystem (rb-thunks))
|
|
|
|
;; handler must unwrap file-write-exception, evaluate all rb-thunks, and raise
|
|
;; exception value
|
|
(define (handle-file-write-exception expn)
|
|
(let ([rb-thunks (file-write-exception-rb-thunks expn)])
|
|
(rollback-exec rb-thunks)
|
|
(raise (exn:fail (exn-message expn) (current-continuation-marks)))))
|
|
|
|
;; write-to-file must manually truncate since out-ports do not truncate
|
|
;; (output-port? xexpr? xexpr? rb-thunks? . -> . rb-thunks?)
|
|
(define (write-to-file out-port new-content old-content accumulator #:print-mode? (is-print #f))
|
|
(let ([rb-thunks (cons (thunk (write-to-file-with-retries out-port old-content is-print))
|
|
(hash-ref accumulator 'rb-thunks))])
|
|
(if (port-try-file-lock? out-port 'exclusive)
|
|
;; wrap in handler that raises file-write-exception
|
|
(begin
|
|
(call-with-exception-handler
|
|
(lambda (expn)
|
|
(raise (file-write-exception (exn-message expn)
|
|
(current-continuation-marks)
|
|
rb-thunks)))
|
|
(thunk
|
|
(file-truncate out-port 0)
|
|
((if is-print print display) new-content out-port)
|
|
(port-file-unlock out-port)
|
|
(close-output-port out-port)))
|
|
(hash-update accumulator 'rb-thunks
|
|
(lambda (r) rb-thunks)))
|
|
(raise (file-write-exception
|
|
(~a "couldn't obtain file lock on " out-port)
|
|
(current-continuation-marks)
|
|
rb-thunks)))))
|
|
|
|
(define (write-to-file-with-retries out-port content is-print)
|
|
(with-handlers
|
|
([file-write-exception? (lambda (expn)
|
|
(displayln "filewrite failed with" expn)
|
|
(displayln "retrying")
|
|
(write-to-file-with-retries out-port content is-print))])
|
|
(write-to-file out-port content #:print-mode? is-print)))
|
|
;; ------------
|
|
|
|
;; resource-replacement
|
|
;; --------------------
|
|
;; replace resource in source/<type>/id
|
|
(define (append-post-footer post-xexpr source-url tag-list history-list)
|
|
(let ([post-footer
|
|
(read (open-input-file "source/post-footer.scm"))])
|
|
`(body
|
|
,post-xexpr
|
|
,((eval post-footer ns) source-url tag-list history-list))))
|
|
|
|
|
|
;; returns lambda that takes res-table to be passed into replace-resource
|
|
;; as make-new-content
|
|
(define (get-new-content source-input-port tag-list id)
|
|
(let ([new-content-sans-footer (read (open-input-file n-in))])
|
|
(lambda (res-table)
|
|
(let ([history-list (drop
|
|
(findf (lambda (row) (equal? (first row) id))
|
|
res-table)
|
|
3)])
|
|
(append-post-footer new-content-sans-footer (source-url r-type id) tag-list history-list)))))
|
|
|
|
|
|
;; replace-resource compose chain expression
|
|
(define (replace-resource source-input-port source-output-port make-new-content id)
|
|
(let ([old-content (read source-input-port)])
|
|
(lambda (accumulator)
|
|
(let ([res-table (hash-ref accumulator 'res-table)])
|
|
(hash-update
|
|
(hash-remove
|
|
(write-to-file
|
|
source-output-port
|
|
(make-new-content res-table)
|
|
old-content accumulator #:print-mode? #t)
|
|
'res-table)
|
|
'resource
|
|
identity
|
|
(findf (lambda (row) (equal? (first row) id)) res-table))))))
|
|
;; --------------------
|
|
|
|
|
|
;; res-table update
|
|
;; ----------------
|
|
(define (update-res-table-with-modification old-res-table id)
|
|
(map
|
|
(lambda (row)
|
|
(if (equal? (first row) id)
|
|
(flatten (list (take row 3)
|
|
update-time
|
|
(drop row 3)))
|
|
row))
|
|
old-res-table))
|
|
|
|
(define (get-publish-time res-table id)
|
|
(last (findf (lambda (row) (equal? (first row) id))
|
|
res-table)))
|
|
|
|
;; update-res-table compose chain expression
|
|
(define (update-res-table old-table rt-output-port id)
|
|
(let* ([new-table (update-res-table-with-modification old-table id)]
|
|
[new-content (list->csv new-table)]
|
|
[publish-time (get-publish-time old-table id)])
|
|
(lambda (accumulator)
|
|
(hash-update
|
|
(hash-update
|
|
(write-to-file rt-output-port new-content old-table accumulator)
|
|
'res-table
|
|
identity
|
|
new-table)
|
|
'publish-time
|
|
identity
|
|
publish-time))))
|
|
;; ----------------
|
|
|
|
;; atom-table update
|
|
;; -----------------
|
|
(define (update-atom-table at-input-port at-output-port res-link)
|
|
(let ([old-table (csv->list at-input-port)])
|
|
(lambda (accumulator)
|
|
(let* ([res-row (hash-ref accumulator 'resource)]
|
|
[desc (third res-row)]
|
|
[publish-time (hash-ref accumulator 'publish-time)]
|
|
[new-table (add-atom-entry old-table
|
|
(atom-table-entry l-head res-link desc publish-time #:update-time update-time))])
|
|
(hash-remove
|
|
(hash-remove
|
|
(hash-update
|
|
(write-to-file at-output-port (list->csv new-table) old-table accumulator)
|
|
'atom-table
|
|
identity
|
|
new-table)
|
|
'resource)
|
|
'publish-time)))))
|
|
;; -----------------
|
|
|
|
;; atom feed update
|
|
;; ----------------
|
|
(define (update-atom-feed af-input-port af-output-port make-af-input-port)
|
|
(let* ([old-feed (read-xml af-input-port)])
|
|
(lambda (accumulator)
|
|
(let* ([atom-table (hash-ref accumulator 'atom-table)]
|
|
[new-feed (make-feed ns make-af-input-port atom-table update-time)])
|
|
(write-to-file af-output-port new-feed old-feed accumulator)))))
|
|
|
|
;; ----------------
|
|
|
|
;; accumulator piped through compose chain
|
|
;; needed for passing data as well as for accumulating rollback thunks
|
|
(define (compose-accumulator rb-thunks)
|
|
(hash 'rb-thunks rb-thunks))
|
|
|
|
|
|
|
|
;; run modify with exception handlers
|
|
;; ----------------------------------
|
|
;; handlers evaluate rollback thunks in order before raising exception
|
|
;; to terminate script
|
|
(with-handlers
|
|
;; failure to locate one of the necessary existing files
|
|
([exn:fail:filesystem? handle-error-getting-file]
|
|
;; failure to write updates to existing file
|
|
[file-write-exception? handle-file-write-exception])
|
|
(let*-values
|
|
;; none of the expressions in let-bindings mutate the filesystem
|
|
([(source-input-port source-output-port) (get-source-ports)]
|
|
[(res-table-input-port res-table-output-port) (get-res-table-ports)]
|
|
[(atom-table-input-port atom-table-output-port) (get-atom-table-ports)]
|
|
[(atom-feed-input-port atom-feed-output-port) (get-atom-feed-ports)]
|
|
[(make-atom-input-port) (get-make-atom-input-port)]
|
|
[(old-res-table id) (get-res-table-and-id res-table-input-port)]
|
|
[(res-link) (resource-link r-type id)]
|
|
[(tags) (get-tags r-type id)]
|
|
[(new-content) (get-new-content source-input-port tags id)])
|
|
|
|
|
|
;; compose chain pipes (hash? accumulator) through each expression
|
|
;; at minimum accumulator must contain k-v ('rb-thunks . (list proc? . rest)
|
|
((compose
|
|
(update-atom-feed atom-feed-input-port atom-feed-output-port make-atom-input-port)
|
|
(update-atom-table atom-table-input-port atom-table-output-port res-link)
|
|
;; see above
|
|
(replace-resource source-input-port source-output-port new-content id)
|
|
(update-res-table old-res-table res-table-output-port id))
|
|
(compose-accumulator rollback-thunks))
|
|
|
|
;; only archive after everything else is done
|
|
(archive-file n-in x-test #:modify-mode #t)
|
|
|
|
(displayln "modify was successful")))))
|
|
|
|
(run modify)
|