oxaliq.net/modify.rkt

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)