fix bugs in modify and publish
All checks were successful
ci/woodpecker/push/build-and-deploy Pipeline was successful

file-writing bugs caused problems on file-read depending on wether print or display
was used. publish was not overwriting existing feed.
This commit is contained in:
sorrel 2024-01-18 13:15:30 -05:00
parent c81dbccac1
commit 7bc26d0864
3 changed files with 13 additions and 13 deletions

View file

@ -80,7 +80,7 @@
;; (. -> . input-port? output-port?) ;; (. -> . input-port? output-port?)
(define (get-source-ports) (define (get-source-ports)
(let ([file-handle (path-add-extension (let ([file-handle (path-add-extension
(if (eq? r-type "root") (if (equal? r-type "root")
(if x-test (if x-test
(build-path "publish-test" "source" l-head) (build-path "publish-test" "source" l-head)
(build-path "source" l-head)) (build-path "source" l-head))
@ -212,8 +212,8 @@
;; write-to-file must manually truncate since out-ports do not truncate ;; write-to-file must manually truncate since out-ports do not truncate
;; (output-port? xexpr? xexpr? rb-thunks? . -> . rb-thunks?) ;; (output-port? xexpr? xexpr? rb-thunks? . -> . rb-thunks?)
(define (write-to-file out-port new-content old-content accumulator) (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)) (let ([rb-thunks (cons (thunk (write-to-file-with-retries out-port old-content is-print))
(hash-ref accumulator 'rb-thunks))]) (hash-ref accumulator 'rb-thunks))])
(if (port-try-file-lock? out-port 'exclusive) (if (port-try-file-lock? out-port 'exclusive)
;; wrap in handler that raises file-write-exception ;; wrap in handler that raises file-write-exception
@ -225,7 +225,7 @@
rb-thunks))) rb-thunks)))
(thunk (thunk
(file-truncate out-port 0) (file-truncate out-port 0)
(display new-content out-port) ((if is-print print display) new-content out-port)
(port-file-unlock out-port) (port-file-unlock out-port)
(close-output-port out-port))) (close-output-port out-port)))
(hash-update accumulator 'rb-thunks (hash-update accumulator 'rb-thunks
@ -235,13 +235,13 @@
(current-continuation-marks) (current-continuation-marks)
rb-thunks))))) rb-thunks)))))
(define (write-to-file-with-retries out-port content) (define (write-to-file-with-retries out-port content is-print)
(with-handlers (with-handlers
([file-write-exception? (lambda (expn) ([file-write-exception? (lambda (expn)
(displayln "filewrite failed with" expn) (displayln "filewrite failed with" expn)
(displayln "retrying") (displayln "retrying")
(write-to-file-with-retries out-port content))]) (write-to-file-with-retries out-port content is-print))])
(write-to-file out-port content))) (write-to-file out-port content #:print-mode? is-print)))
;; ------------ ;; ------------
;; resource-replacement ;; resource-replacement
@ -277,7 +277,7 @@
(write-to-file (write-to-file
source-output-port source-output-port
(make-new-content res-table) (make-new-content res-table)
old-content accumulator) old-content accumulator #:print-mode? #t)
'res-table) 'res-table)
'resource 'resource
identity identity
@ -390,7 +390,7 @@
(compose-accumulator rollback-thunks)) (compose-accumulator rollback-thunks))
;; only archive after everything else is done ;; only archive after everything else is done
(archive-file n-in x-test) (archive-file n-in x-test #:modify-mode #t)
(displayln "modify was successful"))))) (displayln "modify was successful")))))

View file

@ -287,7 +287,7 @@
;; write to file ;; write to file
(if (port-try-file-lock? out 'exclusive) (if (port-try-file-lock? out 'exclusive)
(begin (begin
(write resource out) (print resource out)
(port-file-unlock out) (port-file-unlock out)
(close-output-port out)) (close-output-port out))
(error "couldn't obtain file lock on ~a" out)) (error "couldn't obtain file lock on ~a" out))
@ -321,7 +321,7 @@
(open-output-file (if x "publish-test/source/feed.atom" (open-output-file (if x "publish-test/source/feed.atom"
"source/feed.atom") "source/feed.atom")
;; need to remove this and just replace once testing is done ;; need to remove this and just replace once testing is done
#:exists (if x 'replace 'error))) #:exists 'replace ))
(if (port-try-file-lock? feed-out 'exclusive) (if (port-try-file-lock? feed-out 'exclusive)
(begin (begin
(display (display

View file

@ -24,10 +24,10 @@
(build-path hp (~a resource-id)) (build-path hp (~a resource-id))
(build-path hp resource-type (~a resource-id)))) (build-path hp resource-type (~a resource-id))))
(define (archive-file input-file test) (define (archive-file input-file test #:modify-mode (exists-ok #f))
(if test (if test
(copy-file input-file (string-replace input-file "in-progress" "publish-test/archive") #t) (copy-file input-file (string-replace input-file "in-progress" "publish-test/archive") #t)
(rename-file-or-directory input-file (string-replace input-file "in-progress" "archive")))) (rename-file-or-directory input-file (string-replace input-file "in-progress" "archive") exists-ok)))
;; atom-table utils ;; atom-table utils