holymoly.scm - holymoly - A tor enabled gopher client written in CHICKEN scheme
(HTM) git clone git://vernunftzentrum.de/holymoly.git
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) README
(DIR) 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 identity))
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 (renderer (car l))) cols)
93 (string-take (renderer (car l)) (sub1 cols))
94 (renderer (car l))))
95 (when (and use-cursor (= (+ newp i) (current-cursor 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 selectables))) 0) ; HOME
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 (sub1 rows))))
115 (nsteps left (partition (lambda (x) (< x np)) selectables)))
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 (current-cursor cursor)))) newp)
121 ((263 339)
122 (let* ((np (if (< (- newp rows) 0) 0 (- newp (sub1 rows))))
123 (nsteps left (partition (lambda (x) (< x np)) selectables)))
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:" (entry->string (current-page))))) newp) ; G
130 ((#x67) (k (uristring->entry (get-user-input "New uri:" ))) newp) ; g
131 ((#x48 #x68) (k (uristring->entry *start-page*))) ; h/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 '())) ; CTRL-U
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 gopher-port) until-eof?)
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 (proxy)) server port)
175 (receive (i o) (tcp-connect server port) (values i o #f)))))
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\t70\r\n"))))
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) ".")) (butlast response))
191 (else response))))
192 (e (exn i/o net)
193 (endwin)
194 (new-status "Network error: ~a" ((condition-property-accessor 'exn 'message) 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) 'error)))))))
288 (pager p win: (main-win) renderer: render-entry use-cursor: (not (null? links)) selectables: links)))
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-selector (string #\tab) query))))))
321 (unless (equal? e (current-page))
322 (push! e history))
323 (let* ((res (request-resource (entry-host e) (entry-selector e) (entry-port e) (memq (entry-type e) '(dos-archive binary gif image))))
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 the host part
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)))