342 lines
14 KiB
Racket
342 lines
14 KiB
Racket
#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)
|
|
(only-in "./utils.rkt" homepage git-forge source-url list->csv add-atom-entry atom-table-entry make-feed archive-file)
|
|
csv-reading)
|
|
|
|
(define-namespace-anchor anc)
|
|
(define ns (namespace-anchor->namespace anc))
|
|
|
|
|
|
;; 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 feed
|
|
|
|
;; - move the original input file
|
|
|
|
;; example
|
|
;; publish -input-file in-progress/beginning-latl..scm --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.scm -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 s-url tag-list history-list)
|
|
(let ([post-footer
|
|
(read (open-input-file "source/post-footer.scm"))])
|
|
`(body
|
|
,post-xexpr
|
|
,((eval post-footer ns) s-url 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 " " "-"))
|
|
".scm"))
|
|
(error "'root resource requires headline")))
|
|
(define (make-res-file-handle x r id)
|
|
(path->string (path-add-extension (build-path (if x "publish-test/source" "source") r (~a id))
|
|
".scm")))
|
|
(if (equal? r-type "root")
|
|
(make-root-file-handle x-test l-headline)
|
|
(make-res-file-handle x-test r-type r-id)))
|
|
|
|
(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.scm"))]
|
|
[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"))
|
|
".scm")]
|
|
[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)
|
|
(append (list lookup/id) (rest (hash-ref post-lookup lookup/id)))
|
|
(append (list lookup/id) (rest (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.scm"))]
|
|
[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))
|
|
#".scm")]
|
|
[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.scm"))]
|
|
[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"))
|
|
#".scm")]
|
|
[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-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))))
|
|
|
|
|
|
(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 (string-replace l " " "-"))
|
|
;; 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))
|
|
(source-url r res-id)
|
|
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
|
|
(displayln "updating 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)))
|
|
|
|
(write-csv-to-file (list->csv new-tag-table)
|
|
(if x "publish-test/data/tagged.csv" "data/tagged.csv"))
|
|
|
|
(displayln "updating tagged/'tag")
|
|
;; 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)
|
|
|
|
(displayln "writing resource to file")
|
|
;; write to file
|
|
(if (port-try-file-lock? out 'exclusive)
|
|
(begin
|
|
(print resource out)
|
|
(port-file-unlock out)
|
|
(close-output-port out))
|
|
(error "couldn't obtain file lock on ~a" out))
|
|
|
|
;; update 'resource/index
|
|
(if (equal? r "root")
|
|
(displayln "skipping resource/index")
|
|
(begin
|
|
(displayln "updating resource/index")
|
|
(write-new-resource/index r new-res-table #:test (if x #t #f))))
|
|
|
|
(displayln "updating feed table")
|
|
;; 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 (atom-table-entry 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
|
|
(displayln "updating feed")
|
|
(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 'replace ))
|
|
(if (port-try-file-lock? feed-out 'exclusive)
|
|
(begin
|
|
(display
|
|
(make-feed ns (open-input-file
|
|
(if x
|
|
"publish-test/data/make-atom.scm"
|
|
"data/make-atom.scm"))
|
|
new-atom-table
|
|
publish-time)
|
|
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)
|