git.m455.casa

sprout

clone url: git://git.m455.casa/sprout


sprout.rkt

1 #lang racket/base
2
3 (require racket/port
4 racket/system
5 racket/string
6 racket/file
7 racket/list
8 racket/match)
9
10 (define dir-weed (string-append (path->string (find-system-path 'home-dir)) ".weed/"))
11 (define dir-posts (string-append dir-weed "posts/"))
12 (define dir-build (string-append dir-weed "build/"))
13 (define dirs (list dir-weed dir-posts dir-build))
14
15 (define rss-file "weed.rss")
16 (define rss-file-build (string-append dir-build rss-file))
17
18 (define config-file "config")
19 (define config-file-path (string-append dir-weed config-file))
20
21 (define config-file-contents
22 #<<string-block
23 ;; this is the configuration file for your weed.
24 ;;
25 ;; change these values to your own.
26 ;;
27 ;; note: Make sure you have a slash at the end of
28 ;; the url-base and output-path values.
29
30 ((title "my cool weed")
31 (description "shitposts and feels alllll day")
32 (url-base "https://example.com/weed/")
33 (output-path "user@example.com:/var/www/weed/"))
34
35 ;; Examples of output-path values:
36 ;; Local example: "~/public_html/weed/"
37 ;; Remote example: "user@example.com:/var/www/weed/"
38 ;; Note: Make sure you include the trailing slash
39 string-block
40 )
41
42 (define rss-header
43 #<<string-block
44 <?xml version="1.0" encoding="UTF-8" ?>
45 <rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom">
46 <channel>
47 <title>~a</title>
48 <link>~a</link>
49 <description>~a</description>
50 <atom:link href="~a" rel="self" type="application/rss+xml" />
51
52 string-block
53 )
54
55 (define rss-item
56 #<<string-block
57 <item>
58 <title><![CDATA[~a]]></title>
59 <guid isPermaLink="false"><![CDATA[~a]]></guid>
60 <pubDate>~a</pubDate>
61 <description><![CDATA[~a]]></description>
62 </item>
63
64 string-block
65 )
66
67 (define rss-footer
68 #<<string-block
69 </channel>
70 </rss>
71 string-block
72 )
73
74 (define (config-ref key)
75 (with-input-from-file
76 config-file-path
77 (lambda () (cadr (assq key (read))))))
78
79 (define (rss-remove-illegal-characters str)
80 (string-replace str "]]>" ""))
81
82 (define (clear-screen)
83 (let ([clear-screen "\e[2J"]
84 [reset-cursor "\e[1;1H"])
85 (display (string-append clear-screen reset-cursor))))
86
87 (define-syntax-rule (displayln-format str ...)
88 (displayln (format str ...)))
89
90 (define-syntax-rule (system-format str ...)
91 (system (format str ...)))
92
93 (define (press-enter)
94 (display "press enter to continue...")
95 (read-line))
96
97 (define (directory-create str)
98 (if (directory-exists? str)
99 (displayln-format "directory exists: '~a'. skipping creation." str)
100 (begin (make-directory* str)
101 (displayln-format "created directory: ~a." str))))
102
103 (define (file-create str)
104 (if (file-exists? str)
105 (displayln-format "file exists: '~a'. skipping creation." str)
106 (begin (close-output-port (open-output-file str))
107 (displayln-format "created file: ~a." str))))
108
109 (define (get-editor-fallback)
110 (let ([env-editor (getenv "EDITOR")])
111 (if env-editor
112 env-editor
113 "nano")))
114
115 (define (get-editor)
116 (let ([env-visual (getenv "VISUAL")])
117 (if env-visual
118 env-visual
119 (get-editor-fallback))))
120
121 (define (string-cleanup str)
122 ((compose
123 (lambda (x) (string-replace x #px"\t+" " "))
124 (lambda (x) (string-replace x #px"\\s+" " "))
125 (lambda (x) (string-replace x #px"\\s+$" ""))
126 (lambda (x) (string-replace x #px"\n+" " ")))
127 str))
128
129 (define (string-truncate str max-characters)
130 (if (>= (length (string->list str)) max-characters)
131 (if (equal? max-characters 0)
132 "..."
133 (let ([str-list (string->list str)])
134 (string-cleanup
135 (string-append
136 (string (car str-list))
137 (string-truncate (list->string (cdr str-list)) (- max-characters 1))))))
138 (string-cleanup str)))
139
140 (define (list-paginate lst groups-of-n)
141 (if (null? lst)
142 lst
143 (if (>= (length lst) groups-of-n)
144 (cons (take lst groups-of-n)
145 (list-paginate (list-tail lst groups-of-n) groups-of-n))
146 (cons lst (list-paginate '() groups-of-n)))))
147
148 ;; string-trim removes a trailing "\n" that (system ...) adds
149 (define (shell-command str)
150 (string-trim
151 (with-output-to-string
152 (lambda () (system str)))))
153
154 (define (make-filename)
155 (string-append (shell-command "date +'%Y-%m-%d'") "_"
156 (shell-command "date +'%H-%M-%S'") ".txt"))
157
158 (define (make-title filename)
159 (rss-remove-illegal-characters
160 (string-truncate (file->string filename) 50)))
161
162 (define (make-guid filename)
163 ((compose (lambda (x) (string-replace x ".txt" ""))
164 (lambda (x) (string-replace x dir-posts "")))
165 filename))
166
167 (define (make-date filename)
168 (let* ([date-split (string-split filename "_")]
169 [ymd (string-replace (car date-split) dir-posts "")]
170 [hms ((compose (lambda (x) (string-replace x "-" ":"))
171 (lambda (x) (string-replace x ".txt" "")))
172 (cadr date-split))]
173 [ymd-hms (string-append ymd " " hms)])
174 (shell-command (format "date -Rd'~a'" ymd-hms))))
175
176 (define (make-description filename)
177 ((compose
178 (lambda (x) (string-replace x #px"\n$" "</p>"))
179 (lambda (x) (string-replace x #px"^" "<p>"))
180 (lambda (x) (string-replace x "\n\n" "</p><p>"))
181 rss-remove-illegal-characters)
182 (file->string filename)))
183
184 ;; commands
185 ;; =========================================
186 (define (quit)
187 (clear-screen)
188 (displayln "bye bye! <3")
189 (exit 0))
190
191 (define (publish)
192 (let* ([posts (directory-list dir-posts)]
193 [remote-location (string-append (config-ref 'output-path) rss-file)])
194 (if (> (length posts) 0)
195 (begin (clear-screen)
196 (system-format "rsync -av --delete ~a ~a" rss-file-build remote-location)
197 (displayln "weed published!")
198 (press-enter))
199 (begin (displayln "woops! no posts to publish!")
200 (press-enter)))))
201
202 (define (build-rss)
203 (let ([posts (directory-list dir-posts)])
204 (if (> (length posts) 0)
205 (let* ([posts-as-strings (map path->string posts)]
206 [posts-full-paths (map (lambda (x) (string-append dir-posts x))
207 posts-as-strings)]
208 [header (format rss-header
209 (config-ref 'title)
210 (config-ref 'url-base)
211 (config-ref 'description)
212 (string-append (config-ref 'url-base) rss-file))])
213 ;; write header to file
214 (display-to-file header rss-file-build #:exists 'truncate)
215 ;; write items to file
216 (for ([file posts-full-paths])
217 (let* ([title (make-title file)]
218 [guid (make-guid file)]
219 [date (make-date file)]
220 [description (make-description file)]
221 [item (format rss-item title guid date description)])
222 (display-to-file item rss-file-build #:exists 'append)))
223 ;; write footer to file
224 (display-to-file rss-footer rss-file-build #:exists 'append)
225 (begin (displayln "finished building rss feed!")
226 (press-enter)))
227 (begin (displayln "no posts. skipping rss build...")
228 (press-enter)))))
229
230 (define (delete-post-prompt filename)
231 (let ([title (make-title filename)])
232 (clear-screen)
233 (displayln-format "WARNING: are you sure you want to delete '~a'? [y/n]" title)
234 (display "> ")
235 (let ([input (string-downcase (read-line))])
236 (if (equal? input "y")
237 (delete-file filename)
238 (begin (displayln-format "cancelled deletion of '~a'" title)
239 (press-enter))))))
240
241 (define (delete-post number)
242 (if (and (> (length (directory-list dir-posts)) 0)
243 (>= number 0)
244 (< number (length (directory-list dir-posts))))
245 (let* ([posts-as-strings (map path->string (directory-list dir-posts))]
246 [posts-full-paths (map (lambda (x) (string-append dir-posts x))
247 posts-as-strings)]
248 [filename (list-ref posts-full-paths number)])
249 (delete-post-prompt filename))
250 (begin (displayln "woops!")
251 (press-enter))))
252
253 (define (settings)
254 (system-format "~a ~a" (get-editor) config-file-path))
255
256 (define (edit-post number)
257 (if (and (> (length (directory-list dir-posts)) 0)
258 (>= number 0)
259 (< number (length (directory-list dir-posts))))
260 (let* ([posts-as-strings (map path->string (directory-list dir-posts))]
261 [posts-full-paths (map (lambda (x) (string-append dir-posts x))
262 posts-as-strings)]
263 [filename (list-ref posts-full-paths number)])
264 (system-format "~a ~a" (get-editor) filename))
265 (begin (displayln "woops!")
266 (press-enter))))
267
268 (define (create-post)
269 (let ([filename (string-append dir-posts (make-filename))])
270 (system-format "~a ~a" (get-editor) filename)))
271
272 ;; interface utils
273 ;; =================================
274 ;; credit for wonderful cool symbols:
275 ;; http://coolsymbols123.blogspot.com/2011/05/msn-nickname-decoration.html
276 (define (draw-header)
277 (for ([i (list "(¯`·._.·[ (sprout) ]·._.·´¯)"
278 "h: help | q: quit")])
279 (displayln i)))
280
281 (define (draw-help)
282 (clear-screen)
283 (for ([line (list "c: create a post"
284 "e <n>: edit <nth> post"
285 "d <n>: delete <nth> post"
286 "b: build an rss feed from your posts"
287 "p: publish your posts"
288 "s: change settings")])
289 (displayln line))
290 (newline)
291 (press-enter))
292
293 ;; TODO: implement pagination using string-paginate
294 (define (draw-posts)
295 (let* ([posts (directory-list dir-posts)]
296 [number-of-posts (length posts)])
297 (if (equal? number-of-posts 0)
298 (displayln "you don't have any posts.")
299 (for ([i (map number->string (range number-of-posts))]
300 [file (map path->string posts)])
301 (let ([post-title (make-title (string-append dir-posts file))])
302 (displayln (string-append i ". " post-title)))))))
303
304 (define (prompt-input)
305 (display "> ")
306 (let ([input (string-downcase (read-line))])
307 (match (string-split input)
308 [(list "e" (app string->number (? number? x))) (edit-post x)]
309 [(list "d" (app string->number (? number? x))) (delete-post x)]
310 [(list "s") (settings)]
311 [(list "h") (draw-help)]
312 [(list "c") (create-post)]
313 [(list "b") (build-rss)]
314 [(list "p") (publish)]
315 [(list "q") (quit)]
316 [_ (begin (displayln "not an option")
317 (press-enter))])))
318
319 (define (draw-interface)
320 (clear-screen)
321 (draw-header)
322 (newline)
323 (draw-posts)
324 (newline)
325 (prompt-input)
326 (draw-interface))
327
328 ;; setup
329 ;; =================================
330 (define (setup)
331 (for ([i dirs])
332 (directory-create i))
333 (display-to-file config-file-contents config-file-path #:exists 'truncate)
334 (displayln (format "created ~a" config-file-path))
335 (displayln "finished setup!")
336 (press-enter)
337 (draw-interface))
338
339 (define (prompt-to-setup)
340 (clear-screen)
341 (displayln "it looks like you haven't set up your weed yet.")
342 (displayln "would you like to set it up now? [y/n]")
343 (display "> ")
344 (let ([input (read-line)])
345 (if (equal? (string-downcase input) "y")
346 (setup)
347 (begin (newline)
348 (displayln "cancelled setup.")))))
349
350 (define (main)
351 (if (and (andmap directory-exists? dirs)
352 (file-exists? config-file-path))
353 (draw-interface)
354 (prompt-to-setup)))
355
356 (main)
357