oxaliq.net/publish.rkt

#lang cli

(require (only-in racket/string non-empty-string? string-prefix? string-replace string-split)
         (only-in racket/date current-date date->string date-display-format)
         (only-in racket/format ~a)
         (only-in racket/list append* first second third fourth fifth rest flatten add-between take)
         (only-in xml xexpr->string)
         csv-reading)

(define-namespace-anchor anc)
(define ns (namespace-anchor->namespace anc))

(define homepage "https://sorrel.dev")

               
;; publish needs to:

;: - take an input file, build a source file in the appropriate place in source/

;; - update a read-table for tags

;; - update a read-table for resource type

;; - update the atom.txt feed

;; - move the original input file 

;; example
;; publish -input-file in-progress/beginning-latl.txt --resource-type unsettled --tags latl,conlang \
;; --headline "Beginning LATL" --description "beginning the process of thinking through an environment \
;; for conlanging and other language shenanigans"
;; publish -i in-progress/beginning-latl.txt -r unsettled -t latl,conlang -l "Beginning LATL" \
;; -d "beginning the process of thinking through an environment for conlanging and other language shenanigans"
(help (usage "Publish is here to put yr posts together."))


(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 'failed "couldn't recognize resource. please use one of 'settled' 'unsettled' 'root'")])))

(flag (tags #:param [tags ""] t)
      ("-t" "--tags" "Tags to apply to resource")
      (tags (if (non-empty-string? t)
                (string-split t ",")
                (error 'failure "no tags supplied. please provide tags as comma separated values"))))
       
(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 (description #:param [description ""] d)
      ("-d" "--description" "a little preview description of the post")
      (description (if (non-empty-string? d)
                       d
                       (error 'failure "your post needs a short description"))))

(flag (test-mode)
      ("-x" "--test-mode" "publishes to test directory")
      (test-mode #t))

(define (read-tag-lookup)
  (let ([l (eval (read (open-input-file "tag-lookup.rkt")))])
    (print l)))

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

(define (make-output-file-handle x-test r-type #:headline [l-headline ""] #:res-id [r-id 0])
  (define (make-root-file-handle x l)
    (if (non-empty-string? l)
        (path->string (path-add-extension (build-path (if x "publish-test/source" "source")
                                                      (string-replace l " " "-"))
                                          ".txt"))
        (error "'root resource requires headline")))
  (define (make-res-file-handle x r id)
    (if (< 0 id)
        (path->string (path-add-extension (build-path (if x "publish-test/source" "source") r (~a id))
                                          ".txt"))
        (error "~a resource requires r-id" r)))
  (if (equal? r-type "root")
      (make-root-file-handle x-test l-headline)
      (make-res-file-handle x-test r-type r-id)))

(define (archive-file i x)
  (if x
      (copy-file i (string-replace i "in-progress" "publish-test/archive") #t)
      (rename-file-or-directory i (string-replace i "in-progress" "archive"))))

(define (write-new-tagged/index tag-table #:test [x #f])
  (displayln "write-new-tagged/index")
  (let* ([tags (rest (map (lambda (row) (first row))
                         tag-table))]
         [make-index (read (open-input-file "source/make-index.txt"))]
         [new-index ((eval make-index ns) "tagged" tags)]
         [handle (path-add-extension (if x
                                        (build-path "publish-test" "source" "tagged" "index")
                                        (build-path "source" "tagged" "index"))
                                    ".txt")]
        [file (open-output-file handle #:exists 'replace)])
    (if (port-try-file-lock? file 'exclusive)
        (begin
          (print new-index file)
          (port-file-unlock file)
          (close-output-port file))
        (error "couldn't obtain file lock on ~a" file))))

(define (write-new-tagged/tag/index tag-table-row post-lookup #:test [x #f])
  (displayln "write-new-tagged/tag/index")
  (define (make-resource-lookup resource test)
    (let ([res-table (csv->list(open-input-file
                                 (path-add-extension
                                  (if x
                                      (build-path "publish-test" "data" resource)
                                      (build-path "data" resource))
                                  #".csv")))]
          [res-lookup (make-weak-hash)])
      (for-each (lambda (post)
                  (hash-set! res-lookup (first post) post))
                (rest res-table))
      res-lookup))
  (define (get-post-data lookup/id r-lookup p-lookup test)
    (let* ([r/id (string-split lookup/id "/")]
           [resource (first r/id)]
           [id (second r/id)])
      (if (hash-has-key? r-lookup resource)
          (let ([post-data (hash-ref (hash-ref r-lookup resource) id)])
            (hash-set! p-lookup r/id post-data)
            post-data)
          (let ([res-lookup (make-resource-lookup resource test)])
            (hash-set! r-lookup resource res-lookup) 
            (hash-set! p-lookup r/id (hash-ref res-lookup id))
            (hash-ref p-lookup r/id)))))
  (let* ([tag (first tag-table-row)]
         [resources (make-weak-hash)]
         [posts (map (lambda (lookup/id)
                      (if (hash-has-key? post-lookup lookup/id)
                          (hash-ref post-lookup lookup/id)
                          (get-post-data lookup/id resources post-lookup x)))
                    (filter non-empty-string? (rest tag-table-row)))]
         [make-index (read (open-input-file "source/make-index.txt"))]
         [new-index ((eval make-index ns) (~a "tagged/" tag) posts)]
         [handle (path-add-extension (if x
                                         (build-path "publish-test" "source" "tagged" (first tag-table-row))
                                         (build-path "source" "tagged" tag))
                                     #".txt")]
         [file (open-output-file handle #:exists 'replace)])
    (if (port-try-file-lock? file 'exclusive)
        (begin
          (print new-index file)
          (port-file-unlock file)
          (close-output-port file))
        (error "couldn't obtain file lock on ~a" file))))


(define (write-new-resource/index resource resource-table #:test [x #f])
  (displayln "write-new-resource/index")
  (let* ([make-index (read (open-input-file "source/make-index.txt"))]
         [new-index ((eval make-index ns) resource (rest resource-table))]
         [handle (path-add-extension (if x
                                         (build-path "publish-test" "source" resource "index")
                                         (build-path "source" resource "index"))
                                     #".txt")]
         [file (open-output-file handle #:exists 'replace)])
    (if (port-try-file-lock? file 'exclusive)
        (begin
          (print new-index file)
          (port-file-unlock file)
          (close-output-port file))
        (error "couldn't obtain file lock on ~a" file))))

;; takes a parsed table as a list of lists and formats for writing as a .csv file
(define (list->csv l)
  (foldl (lambda (i res)
           (string-append res i))
         ""
         (flatten
          (add-between (map (lambda (row)
                              (add-between row ","))
                            l)
                       "\n"))))


(define (write-csv-to-file data handle)
  (let ([file (open-output-file handle #:exists 'replace)])
    (if (port-try-file-lock? file 'exclusive)
        (begin
          (display data file)
          (port-file-unlock file)
          (close-output-port file))
        (error "couldn't obtain file lock on ~a" file))))

(define (write-new-tag-table old-tag-table tag-list type res-id)
  (let* ([res (~a type "/" res-id)]
         [new-tt (map (lambda (row)
                        (let ([row-tag (first row)])
                          (if (member row-tag tag-list)
                              (begin
                                (set! tag-list (remove row-tag tag-list))
                                (append (list row-tag res) (rest row)))
                              row)))
                      old-tag-table)])
    (if (null? tag-list)
        new-tt
        (begin (for-each (lambda (new-tag)
                           (set! new-tt (append new-tt (list (list new-tag res)))))
                         tag-list)
               new-tt))))

 (define (add-atom-entry atom-table new-row)
  ;; take only first 21 rows (or all rows)
  ;; insert new-row after header
    (let ([out-length (min (+ 1 (length atom-table)) 21)]
          [header (first atom-table)]
          [old-content (rest atom-table)])
      (take (append (list header new-row) old-content)
            out-length)))


(program
 (publish)
 (let ([i (input)]
       [r (resource-type)]
       [t (tags)]
       [l (headline)]
       [d (description)]
       [x (test-mode)]
       [publish-time (date->string (current-date) (date-display-format 'iso-8601))])
   (displayln "running publish")
   
   ;; get res id
   (define res-table (csv->list (open-input-file
                                 (path-add-extension
                                  (if x
                                      (build-path "publish-test" "data" r)
                                      (build-path "data" r))
                                  #".csv"))))
   
   (define res-id (if (equal? r "root")
                      (string-replace l " " "-")
                      (length res-table)))
   ;; before anything else, open output file
   ;; doing this means that if a file exists of the intended
   (define out
     (if (equal? r "root")
         (open-output-file (make-output-file-handle x r #:headline l) #:exists (if x 'replace 'error))
         (open-output-file (make-output-file-handle x r #:res-id res-id) #:exists (if x 'replace 'error))))
   (define res-link (if (equal? r "root")
                        (build-path homepage (~a res-id))
                        (build-path homepage r (~a res-id))))

   
   (define resource (append-post-footer (read (open-input-file i))
                                        t
                                        (list publish-time)))


   (define new-res-table (append (list (first res-table)) (list (list (~a res-id) l d publish-time)) (rest res-table)))
   (write-csv-to-file (list->csv new-res-table)
                      (path-add-extension
                       (if x
                           (build-path "publish-test" "data" r)
                           (build-path "data" r))
                       #".csv"))


   ;; update tag table
   (define tag-table (csv->list (open-input-file
                                  (if x "publish-test/data/tagged.csv" "data/tagged.csv"))))
   (define new-tag-table (write-new-tag-table tag-table t r res-id))
   ;; update tagged/index if needed
   (if (eq? (length new-tag-table) (length tag-table))
       'continue
       (if x
           (write-new-tagged/index new-tag-table #:test #t)
           (write-new-tagged/index new-tag-table)))
   ; (displayln new-tag-table)
   (write-csv-to-file (list->csv new-tag-table)
                      (if x "publish-test/data/tagged.csv" "data/tagged.csv"))


   ;; update tagged/'tag for each tag
   (for-each
       (lambda (tt-row)
         ;; post-lookup is a hash-table of (resource/id . post-info) where post-info is (id headline description history ...)
         (let ([post-lookup (make-weak-hash)]
               [tt-tag (first tt-row)])
           (if (member tt-tag t)
               ;; rewrite tagged/'tag
               (if x
                   (write-new-tagged/tag/index tt-row post-lookup #:test #t)
                   (write-new-tagged/tag/index tt-row post-lookup))
               '())))
       new-tag-table)
   

   ;; write to file
   (if (port-try-file-lock? out 'exclusive)
       (begin
         (write resource out)
         (port-file-unlock out)
         (close-output-port out))
       (error "couldn't obtain file lock on ~a" out))

   ;; update 'resource/index
   (write-new-resource/index r new-res-table #:test (if x #t #f))


   ;; update feed table
   (define atom-table (csv->list
                       (open-input-file
                        (path-add-extension
                         (if x
                             (build-path "publish-test" "data" "atom")
                             (build-path "data" "atom"))
                         #".csv"))))
   (define new-atom-table
     (add-atom-entry atom-table (list l (~a res-link) d publish-time)))
   (write-csv-to-file (list->csv new-atom-table)
                      (if x "publish-test/data/atom.csv" "data/atom.csv"))

   
   ;; update feed.atom
   ;; for now, this does not include the html for the post, only a link
   (define feed ((eval (read (open-input-file (if x
                                                  "publish-test/data/make-atom.txt"
                                                  "data/make-atom.txt"))) ns)
                 "https://sorrel.dev/feed.atom"
                 publish-time
                 homepage
                 (rest new-atom-table)))
   (define feed-out
     (open-output-file (if x "publish-test/source/feed.atom"
                           "source/feed.atom")
                       ;; need to remove this and just replace once testing is done
                       #:exists (if x 'replace 'error)))
   (if (port-try-file-lock? feed-out 'exclusive)
       (begin
         (display 
          (string-append "<?xml version=\"1.0\" encoding=\"utf-8\"?>"
                                 (xexpr->string feed))
                   feed-out)
         (port-file-unlock feed-out)
         (close-output-port feed-out))
       (error "couldn't obtain file lock on ~a" feed-out))                                                  
                                                      

   ;; only archive after everything else is done
   (archive-file i x)
   
   (displayln "publish was successful")))

;;; (run publish)

(run publish #("-i" "in-progress/beginning-latl.txt"
               "-r" "unsettled"
               "-t" "latl,conlang"
               "-l" "Beginning LATL"
               "-d" "beginning the process of thinking through an environment for conlanging and other language shenanigans"
               "-x"))