oxaliq.net/modify.rkt

#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 "./utils.rkt" list->csv resource-link atom-table-entry add-atom-entry
                  make-feed archive-file))

(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 <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 (equal? 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 #: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/<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 #: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)