#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 /index or tagged//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 / [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//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)