fix bugs in modify and publish
All checks were successful
ci/woodpecker/push/build-and-deploy Pipeline was successful
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:
parent
c81dbccac1
commit
7bc26d0864
3 changed files with 13 additions and 13 deletions
18
modify.rkt
18
modify.rkt
|
@ -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")))))
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue