From fe8ecbcd755caa5786ee2568ddbcd6a3e38a9774 Mon Sep 17 00:00:00 2001 From: sorrel Date: Sun, 14 Jan 2024 18:58:38 -0500 Subject: [PATCH] create modify script --- .dev-log | 52 +++++- data/tagged.csv | 2 - data/unsettled.csv | 1 - modify.rkt | 401 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 449 insertions(+), 7 deletions(-) create mode 100644 modify.rkt diff --git a/.dev-log b/.dev-log index 369cf98..5657900 100644 --- a/.dev-log +++ b/.dev-log @@ -1,16 +1,60 @@ -21/12/2023 +2024/01/14 + + +2024/01/13 +- update atom-table-writing +- finish atom-feed-recreation in modify +- modify functionality complete +- START HERE: + - update all references to old url +- TODO: + - add content in atom + - re-publish stuff in publish branch + +2024/01/11 +- rebuilding post-footer +- created tools/utils.rkt to put utils shared between modify + and publish (includes new url) +- update-atom-table writing +- START HERE: + - update-atom-table needs description for post + +2024/01/08 +- rb-thunks accumulating via compose +- update-res-table now adding update-history to data/.csv +- started loading tag-list for rebuilding post-footer +- START HERE: + - rebuild post-footer + - update-atom-table +- TODO: + - update all references to old url (especially in atom feed) + - update light-mode style + +2024/01/07 +- returning to project +- refactor get-res-table and get-output-file for returning input and output ports + - rb thunk will require read from input-file-port to rewrite contents on fail +- TODO: + - initialize rb-thunks and ensure they accumulate on passage to each handler + +2023/12/30 +- starting work on "modify" script +- custom errors that emit a list of "rollback thunks" to enable resetting + to prior state if any error is raised + +2023/12/21 - broke "about" into smaller sections and linked from "/" - removed "about" from header - now just [settled | unsettled | feed] - added "now" and "this" sections and linked from "/" -10/12/2023 +2023/12/10 - added resource/index builder to publish script -4/12/2023 +2023/12/04 - added function to build index source xexpr file for tagged/'tag - fixed tagged/ index source xexpr printing to file so that it can be read -30/11/2023 +2023/11/30 - added function to build an index source xexpr file for tagged/ - have not tested to see if it builds tagged/ properly yet diff --git a/data/tagged.csv b/data/tagged.csv index d3b67a5..d333ca1 100644 --- a/data/tagged.csv +++ b/data/tagged.csv @@ -1,3 +1 @@ tags,-> -latl,unsettled/1 -conlang,unsettled/1 \ No newline at end of file diff --git a/data/unsettled.csv b/data/unsettled.csv index 9948191..c545860 100644 --- a/data/unsettled.csv +++ b/data/unsettled.csv @@ -1,2 +1 @@ id,headline,description,history-> -1,Beginning LATL,beginning the process of thinking through an environment for conlanging and other language shenanigans,2023-12-04T15:20:53 \ No newline at end of file diff --git a/modify.rkt b/modify.rkt new file mode 100644 index 0000000..9cfcb36 --- /dev/null +++ b/modify.rkt @@ -0,0 +1,401 @@ +#lang cli + +(require (only-in racket/date current-date date->string date-display-format) + (only-in racket/string string-join 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 "./tool/utils.rkt" list->csv resource-link atom-table-entry add-atom-entry make-feed)) + +(define-namespace-anchor anc) +(define ns (namespace-anchor->namespace anc)) + +(define homepage "https://sorrel.dev") + + +;; 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 /index or tagged//index pages ! +;; (these pages do not currently show post history) + +;; - update the atom.txt feed + +;; example +;; modify -input-file in-progress/beginning-latl.txt --resource-type unsettled +;; --headline "Beginning LATL" +;; publish -i in-progress/beginning-latl.txt -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-handle (path-add-extension + (if (eq? r-type "root") + (if x-test + (build-path "publish-test" "source" l-head) + (build-path "source" l-head)) + (if x-test + (build-path "publish-test" "source" r-type l-head) + (build-path "source" r-type l-head))) + #".txt")]) + (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.txt 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")) + #".txt")]) + (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 / + [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) + (let ([rb-thunks (cons (thunk (write-to-file-with-retries out-port old-content)) + (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) + (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) + (with-handlers + ([file-write-exception? (lambda (expn) + (displayln "filewrite failed with" expn) + (displayln "retrying") + (write-to-file-with-retries out-port content))]) + (write-to-file out-port content))) + ;; ------------ + + ;; resource-replacement + ;; -------------------- + ;; replace resource in source//id + (define (append-post-footer post-xexpr tag-list history-list) + (let ([post-footer + (read (open-input-file "source/post-footer.txt"))]) + `(body + ,post-xexpr + ,((eval post-footer ns) 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 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) + '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))]) + (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 #:homepage homepage)]) + (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 #:homepage homepage)] + [(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)))) + + ;; + )) + +;(run modify) + +(run modify #("-i" "in-progress/now.txt" + "-l" "now" + "-r" "root" + "-x")) \ No newline at end of file