holymoly.scm - holymoly - A tor enabled gopher client written in CHICKEN scheme | |
git clone git://vernunftzentrum.de/holymoly.git | |
Log | |
Files | |
Refs | |
README | |
LICENSE | |
--- | |
holymoly.scm (15126B) | |
--- | |
1 (include "proxy.scm") | |
2 (include "cursor.scm") | |
3 | |
4 (module holymoly (main) | |
5 (import | |
6 (chicken base) | |
7 (chicken bitwise) | |
8 (chicken condition) | |
9 (chicken file posix) | |
10 (chicken foreign) | |
11 (chicken format) | |
12 (chicken io) | |
13 (chicken irregex) | |
14 (chicken port) | |
15 (chicken pretty-print) | |
16 (chicken process) | |
17 (chicken process-context) | |
18 (chicken process signal) | |
19 (chicken string) | |
20 (chicken tcp) | |
21 ioctl | |
22 matchable | |
23 miscmacros | |
24 ncurses | |
25 scheme | |
26 srfi-1 | |
27 srfi-13 | |
28 srfi-4 | |
29 srfi-71) | |
30 | |
31 (define *start-page* "gopher://vernunftzentrum.de/1/ckeen") | |
32 (define *search-uri* "gopher://gopher.floodgap.com:70/7/v2/vs") | |
33 | |
34 (foreign-declare "#include <locale.h>") | |
35 (foreign-code "setlocale(LC_ALL, \"en_US.UTF-8\");") | |
36 | |
37 (import socksv5-proxy) | |
38 (import cursor) | |
39 | |
40 (define gopher-port 70) | |
41 (define index "") | |
42 (define tab (string #\tab)) | |
43 (define rows 0) | |
44 (define cols 0) | |
45 (define next-step values) | |
46 | |
47 (define-record entry type title selector host port rest) | |
48 (define-record-printer entry | |
49 (lambda (e p) | |
50 (fprintf p "#<entry '~a ~s ~s ~s ~s>" (entry-type e) | |
51 (if (> (string-length (entry-title e)) 6) | |
52 (string-append (string-take (entry-title e) 6) "...") | |
53 (entry-title e)) | |
54 (entry-selector e) | |
55 (entry-host e) | |
56 (entry-port e)))) | |
57 | |
58 (define proxy | |
59 (and-let* | |
60 ((proxy-vals (or (get-environment-variable "SOCKS_PROXY") | |
61 "localhost:9050")) | |
62 (conf | |
63 (if (not (string-null? proxy-vals)) | |
64 (string-split proxy-vals ":") | |
65 #f)) ;; no proxy configured, so abort here | |
66 (proxy-host (car conf)) | |
67 (proxy-port (string->number (cadr conf)))) | |
68 (make-parameter (cons proxy-host proxy-port)))) | |
69 | |
70 | |
71 (define main-win (make-parameter #f)) | |
72 (define status-win (make-parameter #f)) | |
73 | |
74 (define (pager lines #!key win use-cursor (selectables '()) (renderer id… | |
75 (when (and use-cursor (or (not selectables) (null? selectables))) | |
76 (error "Usage of use-cursor without handing in selectables")) | |
77 (unless win | |
78 (error "Need window parameter")) | |
79 (let ((nlines (length lines)) | |
80 (cursor 0)) | |
81 (when use-cursor | |
82 (set! cursor (list->cursor selectables))) | |
83 (call/cc | |
84 (lambda (k) | |
85 (let loop ((newp 0)) | |
86 (let* ((rows cols (getmaxyx win)) | |
87 (dlines (take (drop lines newp) (min (- nlines newp) rows… | |
88 (wclear win) | |
89 (let draw ((l dlines) | |
90 (i 0)) | |
91 (unless (or (>= i rows) (null? l)) | |
92 (mvwprintw win i 0 "~a" (if (>= (string-length (ren… | |
93 (string-take (renderer … | |
94 (renderer (car l)))) | |
95 (when (and use-cursor (= (+ newp i) (current-cursor… | |
96 (let ((e (list-ref lines (+ newp i)))) | |
97 (new-status "~a" (entry->string e))) | |
98 (mvwchgat win i 0 -1 A_STANDOUT 0 #f)) | |
99 (draw (cdr l) (add1 i)))) | |
100 (wrefresh win) | |
101 (loop (case (char->integer (getch)) | |
102 ((16 #x103 107) ; arrow up / k | |
103 (cond | |
104 (use-cursor (prev-cursor! cursor) newp) | |
105 (else (if (zero? newp) 0 (sub1 newp))))) | |
106 ((14 #x102 106) ; arrow down / j | |
107 (cond | |
108 (use-cursor (next-cursor! cursor) newp) | |
109 (else (if (= newp nlines) newp (add1 newp))))) | |
110 ((#x106) (when use-cursor (set! cursor (list->cursor … | |
111 ((#x168) (max newp (- nlines newp rows))) ; end | |
112 ((260) (k (previous-page))) | |
113 ((32 338) | |
114 (let* ((np (if (> (+ newp rows) nlines) newp (+ newp… | |
115 (nsteps left (partition (lambda (x) (< x np))… | |
116 (when use-cursor | |
117 (set! cursor (list->cursor selectables)) | |
118 (repeat (length nsteps) (next-cursor! cursor))) | |
119 np)) ; space / pgup | |
120 ((10 261) (when use-cursor (k (list-ref lines (curren… | |
121 ((263 339) | |
122 (let* ((np (if (< (- newp rows) 0) 0 (- newp (sub1 r… | |
123 (nsteps left (partition (lambda (x) (< x np))… | |
124 (when use-cursor | |
125 (set! cursor (list->cursor selectables)) | |
126 (repeat (length nsteps) (next-cursor! cursor))) | |
127 np)) ; backspace / pgdown | |
128 ((113) (k 'quit)) ; q | |
129 ((#x47) (k (uristring->entry (get-user-input "New uri… | |
130 ((#x67) (k (uristring->entry (get-user-input "New uri… | |
131 ((#x48 #x68) (k (uristring->entry *start-page*))) ; h… | |
132 ((115) (k (uristring->entry *search-uri*))) | |
133 (else newp))))))))) | |
134 | |
135 (define (get-user-input #!optional (prompt "Enter query:") (suggestion "… | |
136 (let* ((l c (getmaxyx (stdscr))) | |
137 (w (newwin 3 c (quotient l 2) 0))) | |
138 (let input-loop ((r (reverse (string->list suggestion)))) | |
139 (define (refresh r) | |
140 (wclear w) | |
141 (box w 0 0) | |
142 (mvwprintw w 0 (- (quotient c 2) | |
143 (quotient (string-length prompt) 2)) prompt) | |
144 (mvwprintw w 1 2 "~a" (list->string (reverse r))) | |
145 (mvwchgat w 1 (+ 2 (length r)) 1 A_BLINK 0 #f) | |
146 (wrefresh w)) | |
147 (refresh r) | |
148 (let ((input (getch))) | |
149 (select (char->integer input) | |
150 ((10) (delwin w) (list->string (reverse r))) | |
151 ((263) (let ((new (if (null? r) r (cdr r)))) | |
152 (refresh new) | |
153 (input-loop new))) | |
154 ((list (bitwise-and 31 85)) (refresh '()) (input-loop '())) ; … | |
155 ((27) suggestion) | |
156 (else | |
157 (refresh (cons input r)) | |
158 (input-loop (cons input r)))))))) | |
159 | |
160 (define (new-status . msg) | |
161 (let* ((m0 (apply sprintf msg)) | |
162 (m (irregex-replace/all "~" m0 "~~"))) | |
163 (let-values (((l c) (getmaxyx (status-win)))) | |
164 (wclear (status-win)) | |
165 (mvwprintw (status-win) 0 0 m) | |
166 (mvwchgat (status-win) 0 0 -1 A_STANDOUT 0 #f) | |
167 (wrefresh (status-win)) | |
168 (doupdate)))) | |
169 | |
170 (define (request-resource server #!optional (resource index) (port gophe… | |
171 (new-status "Connecting to ~a:~a ~a " server port resource) | |
172 (condition-case | |
173 (let-values (((i o _) (if proxy | |
174 (connect/socksv5 (car (proxy)) (cdr (prox… | |
175 (receive (i o) (tcp-connect server port) … | |
176 (new-status "connected.") | |
177 (display (string-append resource (string #\return #\linefeed)) o) | |
178 (let ((response (if until-eof? | |
179 (read-u8vector #f i) | |
180 (read-lines i))) | |
181 (empty-response | |
182 (if until-eof? | |
183 #u8() | |
184 '("iGot an empty response from server\tfoo\tserver\t… | |
185 (close-input-port i) | |
186 (close-output-port o) | |
187 (cond ((or (eof-object? response) (null? response)) | |
188 empty-response) | |
189 (until-eof? response) | |
190 ((and (pair? response) (equal? (last response) ".")) (but… | |
191 (else response)))) | |
192 (e (exn i/o net) | |
193 (endwin) | |
194 (new-status "Network error: ~a" ((condition-property-accessor 'e… | |
195 (sleep 1) | |
196 (beep) | |
197 (select-entry (previous-page))) | |
198 (e () | |
199 (endwin) | |
200 (pp (condition->list e)) | |
201 (abort e)))) | |
202 | |
203 | |
204 (define mapping-table | |
205 '(("i" . info) | |
206 ("0" . file) | |
207 ("1" . directory) | |
208 ("2" . cso-phone-book-server) | |
209 ("3" . error) | |
210 ("4" . binhex) | |
211 ("5" . dos-archive) ;; must read to end of file | |
212 ("6" . uuencoded-file) | |
213 ("7" . index-search) | |
214 ("8" . telnet) | |
215 ("9" . binary) ;; must read to end of file | |
216 ("+" . redundant-server) | |
217 ("T" . tn3270-session) | |
218 ("g" . gif) | |
219 ("I" . image) | |
220 ("h" . url))) | |
221 | |
222 (define (swap pair) (cons (cdr pair) (car pair))) | |
223 | |
224 (define (string->type str #!optional (default 'unknown)) | |
225 (or (alist-ref str mapping-table equal?) default)) | |
226 | |
227 (define (type->string type) | |
228 (or (alist-ref type (map swap mapping-table) equal?) "3")) | |
229 | |
230 (define (string->entry str) | |
231 (condition-case | |
232 (let* ((s (string-split str tab #t)) | |
233 (type (string->type (string-take (car s) 1))) | |
234 (title (string-drop (car s) 1)) | |
235 (selector (second s)) | |
236 (host (third s)) | |
237 (port (string->number (fourth s))) | |
238 (rest (cdddr s))) | |
239 (make-entry type title selector host port rest)) | |
240 (e () (make-entry 'error "..." "" "" "" '())))) | |
241 | |
242 (define (render-entry e) | |
243 (match (entry-type e) | |
244 ('info | |
245 (sprintf " ~a" (entry-title e))) | |
246 ('error | |
247 (sprintf " ! ~a" (entry-title e))) | |
248 (else | |
249 (sprintf " > ~a" (entry-title e))))) | |
250 | |
251 (define (xdg-open r) | |
252 (cond ((string? r) | |
253 (process "xdg-open" (list (string-join (cdr (string-split r ":")… | |
254 ((and (u8vector? r) (not (zero? (u8vector-length r)))) | |
255 (let-values (((fd temp-path) (file-mkstemp "/tmp/holymoly.XXXXXX… | |
256 (let ((temp-port (open-output-file* fd))) | |
257 (write-u8vector r temp-port) | |
258 (close-output-port temp-port)) | |
259 (process "xdg-open" (list temp-path))))) | |
260 (previous-page)) | |
261 | |
262 (define history '()) | |
263 | |
264 (define (current-page) | |
265 (if (null? history) | |
266 #f | |
267 (car history))) | |
268 | |
269 (define (previous-page) | |
270 (when (< 1 (length history)) | |
271 (pop! history)) | |
272 (current-page)) | |
273 | |
274 (define (get-indices lst pred) | |
275 (let loop ((l lst) | |
276 (r '()) | |
277 (i 0)) | |
278 (if (not (pair? l)) (reverse r) | |
279 (if (pred (car l)) | |
280 (loop (cdr l) (cons i r) (add1 i)) | |
281 (loop (cdr l) r (add1 i)))))) | |
282 | |
283 (define (render-directory strs) | |
284 (let* ((p (map string->entry strs)) | |
285 (links (get-indices p (lambda (e) | |
286 (not (or (equal? (entry-type e) 'info) | |
287 (equal? (entry-type e) … | |
288 (pager p win: (main-win) renderer: render-entry use-cursor: (not (nu… | |
289 | |
290 (define type-handlers | |
291 `((file . ,(lambda (c) (pager c win: (main-win)))) | |
292 (directory . ,render-directory) | |
293 (index-search . ,render-directory) | |
294 (image . ,(lambda (c) (xdg-open c))) | |
295 (gif . ,(lambda (c) (xdg-open c))))) | |
296 | |
297 (define (save-selector entry content) | |
298 (let* ((filename (string-append "/tmp/" | |
299 (last (string-split (entry-selector entry) "/")))) | |
300 (path (get-user-input "Where to save the file:" filename))) | |
301 (unless (string-null? path) | |
302 (with-output-to-file path | |
303 (lambda () (write-u8vector content))) | |
304 (new-status "~a saved." path) | |
305 (sleep 2)) | |
306 (previous-page))) | |
307 | |
308 (define (select-entry e) | |
309 (when (equal? (entry-type e) 'url) | |
310 (xdg-open (entry-selector e)) | |
311 (select-entry (current-page))) | |
312 (when (equal? (entry-type e) 'index-search) | |
313 (let* ((base+query (string-split (entry-selector e) (string #\tab))) | |
314 (query (if (= 1 (length base+query)) | |
315 (get-user-input) | |
316 (string-join (cdr base+query)))) | |
317 (base-selector (car base+query))) | |
318 (if (null? query) | |
319 (select-entry (current-page)) | |
320 (entry-selector-set! e (string-concatenate (list base-s… | |
321 (unless (equal? e (current-page)) | |
322 (push! e history)) | |
323 (let* ((res (request-resource (entry-host e) (entry-selector e) (entry… | |
324 (handler (or | |
325 (alist-ref (entry-type e) type-handlers) | |
326 (lambda (c) (save-selector e c)))) | |
327 (next (begin | |
328 (new-status "~a" (entry->string e)) | |
329 (handler res)))) | |
330 (new-status "~a" next) | |
331 (cond | |
332 ((equal? next 'quit) (exit 0)) | |
333 (else (select-entry next))))) | |
334 | |
335 (define (uristring->entry uri-string) | |
336 (let* ((selector (if (string-prefix? "gopher://" uri-string) | |
337 (string-drop uri-string 9) | |
338 uri-string)) | |
339 (split-selectors (string-split selector "/")) | |
340 (host/port (string-split (car split-selectors) ":")) | |
341 (host (car host/port)) ; always the first list entry | |
342 (port (if (> (length host/port) 1) | |
343 (string->number (second host/port)) | |
344 70)) | |
345 (selector (string-join (cdr split-selectors) "/")) ;; without… | |
346 (type (string->type (if (> (string-length selector) 1) | |
347 (string-take selector 1) | |
348 "1"))) | |
349 (final-selector (if (> (string-length selector) 1) | |
350 (string-drop selector 1) | |
351 selector))) | |
352 (make-entry type "" final-selector host port '()))) | |
353 | |
354 (define (entry->string e) | |
355 (sprintf "gopher://~a:~a/~a" | |
356 (entry-host e) | |
357 (entry-port e) | |
358 (string-append (type->string (entry-type e)) | |
359 (entry-selector e)))) | |
360 | |
361 (define (resize-wins _) | |
362 (let ((rows+cols (ioctl-winsize (current-output-port)))) | |
363 (set! rows (car rows+cols)) | |
364 (set! cols (cadr rows+cols)) | |
365 (resizeterm rows cols) | |
366 (wresize (main-win) (sub1 rows) cols) | |
367 (wresize (status-win) 1 cols) | |
368 (mvwin (main-win) 0 0) | |
369 (mvwin (status-win) (sub1 rows) 0) | |
370 (fprintf (current-error-port) "rows ~a cols ~a~%" rows cols) | |
371 (clear) | |
372 (refresh) | |
373 (next-step (current-page)))) | |
374 | |
375 (define (main args) | |
376 (initscr) | |
377 (cbreak) | |
378 (keypad (stdscr) #t) | |
379 (curs_set 0) | |
380 (clear) | |
381 (refresh) | |
382 (noecho) | |
383 (set-signal-handler! signal/winch resize-wins) | |
384 | |
385 (let ((rows+cols (ioctl-winsize (current-output-port))) | |
386 (start-page (if (null? args) *start-page* (car args)))) | |
387 (set! rows (car rows+cols)) | |
388 (set! cols (cadr rows+cols)) | |
389 (main-win (newwin (sub1 rows) cols 0 0)) | |
390 (status-win (newwin 1 cols (sub1 rows) 0)) | |
391 (new-status "Starting up!") | |
392 (select-entry (uristring->entry start-page)) | |
393 (exit 0))) | |
394 | |
395 ) ;;; end of module definition | |
396 | |
397 | |
398 (import (only (chicken process-context) command-line-arguments) | |
399 (only (chicken format) fprintf) | |
400 (only (chicken condition) signal) | |
401 holymoly | |
402 (only ncurses endwin)) | |
403 (handle-exceptions exn | |
404 (begin | |
405 (on-exit void) | |
406 ;; Disable ncurses before printing the error message and call trace | |
407 (endwin) | |
408 (fprintf (current-error-port) "Exception caught: ~s" exn) | |
409 (signal exn)) | |
410 (on-exit endwin) | |
411 (main (command-line-arguments))) |