create modify script
All checks were successful
ci/woodpecker/push/build-and-deploy Pipeline was successful

This commit is contained in:
sorrel 2024-01-14 18:58:38 -05:00
parent 3b16b06255
commit fe8ecbcd75
4 changed files with 449 additions and 7 deletions

View file

@ -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 <entry><content /></>
- 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/<resource>.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 "/" - broke "about" into smaller sections and linked from "/"
- removed "about" from header - now just [settled | unsettled | feed] - removed "about" from header - now just [settled | unsettled | feed]
- added "now" and "this" sections and linked from "/" - added "now" and "this" sections and linked from "/"
10/12/2023 2023/12/10
- added resource/index builder to publish script - added resource/index builder to publish script
4/12/2023 2023/12/04
- added function to build index source xexpr file for tagged/'tag - 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 - 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/ - added function to build an index source xexpr file for tagged/
- have not tested to see if it builds tagged/ properly yet - have not tested to see if it builds tagged/ properly yet

View file

@ -1,3 +1 @@
tags,-> tags,->
latl,unsettled/1
conlang,unsettled/1
1 tags ->
latl unsettled/1
conlang unsettled/1

View file

@ -1,2 +1 @@
id,headline,description,history-> 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
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

401
modify.rkt Normal file
View file

@ -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 <resource>/index or tagged/<tag>/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 <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)
(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/<type>/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"))