create modify script

.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 <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 "/"
 - 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
 

data/tagged.csv

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

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

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 <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"))