initial commit - 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
---
(DIR) commit dd5457cc9ae51143e41ce812badf551c405c8661
(HTM) Author: Christian Kellermann <ckeen@pestilenz.org>
Date: Sun, 4 Mar 2018 12:55:25 +0100
initial commit
Diffstat:
build.sh | 10 ++++++++++
cursor.scm | 101 +++++++++++++++++++++++++++++++
holymoly.scm | 289 +++++++++++++++++++++++++++++++
ncurses-trunk.diff | 20 ++++++++++++++++++++
proxy.scm | 88 +++++++++++++++++++++++++++++++
5 files changed, 508 insertions(+), 0 deletions(-)
---
(DIR) diff --git a/build.sh b/build.sh
@@ -0,0 +1,10 @@
+#!/bin/ksh
+set -e
+
+chicken-install -r ncurses
+cd ncurses
+patch < ../ncurses-trunk.diff
+chicken-install
+cd -
+csc holymoly
+rm -r ncurses *.o
(DIR) diff --git a/cursor.scm b/cursor.scm
@@ -0,0 +1,101 @@
+(module cursor
+
+(cursor->list
+ next-cursor!
+ prev-cursor!
+ empty-cursor?
+ current-cursor
+ list->cursor
+ add-to-tail
+ add-to-head)
+
+(import chicken scheme)
+(use extras srfi-1)
+
+(define-record cursor prev current next)
+
+(define-record-printer cursor
+ (lambda (c p)
+ (fprintf p
+ "#<cursor (~a ->~a<- ~a)>"
+ (reverse (cursor-prev c))
+ (cursor-current c)
+ (cursor-next c))))
+
+(define empty-element (gensym 'cursor))
+
+(define (next-cursor! c)
+ (cond
+ ((empty-cursor? c)
+ (error "Cursor empty"))
+ ((and (null? (cursor-next c))
+ (null? (cursor-prev c)))
+ (cursor-current c))
+ ((null? (cursor-next c))
+ (let* ((old-cur (cursor-current c))
+ (new-next (reverse (cons old-cur (cursor-prev c)))))
+ (cursor-current-set! c (car new-next))
+ (cursor-next-set! c (cdr new-next))
+ (cursor-prev-set! c '())))
+ (else
+ (cursor-prev-set! c (cons (cursor-current c) (cursor-prev c)))
+ (cursor-current-set! c (car (cursor-next c)))
+ (cursor-next-set! c (cdr (cursor-next c)))))
+ (cursor-current c))
+
+(define (prev-cursor! c)
+ (cond
+ ((empty-cursor? c)
+ (error "Cursor empty"))
+ ((and (null? (cursor-next c))
+ (null? (cursor-prev c)))
+ (cursor-current c))
+ ((null? (cursor-prev c))
+ (let* ((old-cur (cursor-current c))
+ (new-prev (reverse (cons old-cur (cursor-next c)))))
+ (cursor-current-set! c (car new-prev))
+ (cursor-prev-set! c (cdr new-prev))
+ (cursor-next-set! c '())))
+ (else
+ (cursor-next-set! c (cons (cursor-current c) (cursor-next c)))
+ (cursor-current-set! c (car (cursor-prev c)))
+ (cursor-prev-set! c (cdr (cursor-prev c)))))
+ (cursor-current c))
+
+(define (current-cursor c)
+ (when (empty-cursor? c)
+ (error "Cursor empty"))
+ (cursor-current c))
+
+(define (list->cursor lst)
+ (unless (list? lst)
+ (error "not a list" lst))
+ (if (null? lst)
+ (make-cursor '() empty-element '())
+ (make-cursor '() (car lst) (cdr lst))))
+
+(define (cursor->list c)
+ (append (reverse (cursor-prev c))
+ (list (cursor-current c))
+ (cursor-next c)))
+
+(define (empty-cursor? c)
+ (and (null? (cursor-prev c))
+ (null? (cursor-next c))
+ (eq? empty-element (cursor-current c))))
+
+(define (add-to-head c elem)
+ (cond ((empty-cursor? c)
+ (cursor-current-set! c elem))
+ (else
+ (cursor-prev-set! c
+ (append-reverse (cursor-prev c) (list elem))))))
+
+(define (add-to-tail c elem)
+ (cond ((empty-cursor? c)
+ (cursor-current-set! c elem))
+ (else
+ (cursor-next-set! c
+ (append (cursor-next c) (list elem))))))
+
+)
(DIR) diff --git a/holymoly.scm b/holymoly.scm
@@ -0,0 +1,289 @@
+(use tcp miscmacros srfi-13 srfi-4 posix ncurses matchable srfi-71)
+
+(include "proxy.scm")
+(include "cursor.scm")
+
+(import socksv5-proxy)
+(import cursor)
+
+(define gopher-port 70)
+(define index "")
+(define tab (string #\tab))
+
+(define proxy
+ (let* ((conf
+ (string-split
+ (or
+ (get-environment-variable "SOCKS_PROXY")
+ "localhost:9050")
+ ":"))
+ (proxy-host (car conf))
+ (proxy-port (string->number (cadr conf))))
+ (make-parameter (cons proxy-host proxy-port))))
+
+
+(define main-win (make-parameter #f))
+(define status-win (make-parameter #f))
+
+(define (pager lines #!key win use-cursor selectables (renderer identity))
+ (when (and use-cursor (or (not selectables) (null? selectables)))
+ (error "Usage of use-cursor without handing in selectables"))
+ (unless win
+ (error "Need window parameter"))
+ (let ((pos 0)
+ (nlines (length lines))
+ (cursor 0))
+ (when use-cursor
+ (set! cursor (list->cursor selectables)))
+ (call/cc
+ (lambda (k)
+ (let loop ((newp 0))
+ (let* ((rows cols (getmaxyx win))
+ (dlines (take (drop lines pos) (min (- nlines pos) rows))))
+ (wclear win)
+ (let draw ((l dlines)
+ (i 0))
+ (unless (or (>= i rows) (null? l))
+ (mvwprintw win i 0 "~a" (if (>= (string-length (renderer (car l))) cols)
+ (string-take (renderer (car l)) (sub1 cols))
+ (renderer (car l))))
+ (when (and use-cursor (= (+ pos i) (current-cursor cursor)))
+ (mvwchgat win i 0 -1 A_STANDOUT 0 #f))
+ (draw (cdr l) (add1 i))))
+ (wrefresh win)
+ (loop (case (char->integer (getch))
+ ((16 #x103) ; arrow up
+ (cond
+ (use-cursor (prev-cursor! cursor) pos)
+ (else (if (zero? pos) 0 (set! pos (sub1 pos))))))
+ ((14 #x102) ; arrow down
+ (cond
+ (use-cursor (next-cursor! cursor) pos)
+ (else (if (= pos nlines) pos (set! pos (add1 pos))))))
+ ((#x106) (when use-cursor (set! cursor 0)) (set! pos 0)) ; HOME
+ ((#x168) (when use-cursor (set! cursor (sub1 (length dlines)))) (set! pos (max pos (- nlines pos rows)))) ; end
+ ((260) (if use-cursor (k (previous-page)) (k #f)))
+ ((32)
+ (set! pos (if (> (+ pos rows) nlines) pos (+ pos (sub1 rows))))
+ (when use-cursor
+ (let adjust-cursor! ()
+ (cond ((> pos (current-cursor cursor))
+ (next-cursor! cursor)
+ (adjust-cursor!))
+ ((< (+ pos (length dlines)) (current-cursor cursor))
+ (prev-cursor! cursor)
+ (adjust-cursor!)))))
+ pos) ; space
+ ((10 261) (when use-cursor (k (list-ref lines (current-cursor cursor)))) pos)
+ ((#x107) (set! pos (if (< (- pos rows) 0) 0 (- pos (sub1 rows))))
+ (when use-cursor
+ (let adjust-cursor! ()
+ (cond ((> pos (current-cursor cursor))
+ (next-cursor! cursor)
+ (adjust-cursor!))
+ ((< (+ pos (length dlines)) (current-cursor cursor))
+ (prev-cursor! cursor)
+ (adjust-cursor!)))))) ; backspace
+ ((113) (k #f)) ; q
+ (else pos)))))))))
+
+(define (get-user-input)
+ (let* ((l c (getmaxyx (stdscr)))
+ (w (newwin 3 c (quotient l 2) 0))
+ (query "Enter query:"))
+ (let input-loop ((r '()))
+ (define (refresh r)
+ (wclear w)
+ (box w 0 0)
+ (mvwprintw w 0 (- (quotient c 2)
+ (quotient (string-length query) 2)) query)
+ (mvwprintw w 1 2 "~a" (list->string (reverse r)))
+ (mvwchgat w 1 (+ 2 (length r)) 1 A_BLINK 0 #f)
+ (wrefresh w))
+ (refresh r)
+ (let ((input (getch)))
+ (case (char->integer input)
+ ((10) (delwin w) (list->string (reverse r)))
+ ((263) (let ((new (if (null? r) r (cdr r))))
+ (refresh new)
+ (input-loop new)))
+ ((27) '())
+ (else
+ (refresh (cons input r))
+ (input-loop (cons input r))))))))
+
+(define (new-status . msg)
+ (let-values (((l c) (getmaxyx (status-win))))
+ (let ((m (apply sprintf msg)))
+ (wclear (status-win))
+ (mvwprintw (status-win) 0 0 (if (> (string-length m) c)
+ (string-take m c)
+ m))
+ (mvwchgat (status-win) 0 0 -1 A_STANDOUT 0 #f)
+ (wrefresh (status-win))
+ (doupdate))))
+
+(define-record entry type title selector host port rest)
+(define-record-printer entry
+ (lambda (e p)
+ (fprintf p "#<entry '~a ~s ~s>" (entry-type e)
+ (if (> (string-length (entry-title e)) 6)
+ (string-append (string-take (entry-title e) 6) "...")
+ (entry-title e))
+ (entry-selector e))))
+
+(define (read-until delim port)
+ (let rl ((r '())
+ (l (read-line port)))
+ (if (or (equal? delim l) (eof-object? l))
+ (reverse r)
+ (rl (cons l r) (read-line port)))))
+
+(define (request-resource server #!optional (resource index) (port gopher-port) until-eof?)
+ (new-status "Connecting to ~a ~a " server resource)
+ (condition-case
+ (let-values (((i o _) (connect/socksv5 (car (proxy)) (cdr (proxy)) server port)))
+ (new-status "connected.")
+ (display (string-append resource (string #\linefeed #\return)) o)
+ (let ((response (read-until (if until-eof? #f ".") i)))
+ (close-input-port i)
+ (close-output-port o)
+ response))
+ (e (exn i/o net)
+ (endwin)
+ (new-status "Network error: ~a" ((condition-property-accessor 'exn 'message) e))
+ (sleep 1)
+ (beep)
+ (select-entry (previous-page)))
+ (e ()
+ (endwin)
+ (pp (condition->list e))
+ (abort e))))
+
+(define (string->type str)
+ (let ((mapping-table
+ '(("i" . info)
+ ("0" . file)
+ ("1" . directory)
+ ("2" . cso-phone-book-server)
+ ("3" . error)
+ ("4" . binhex)
+ ("5" . dos-archive) ;; must read to end of file
+ ("6" . uuencoded-file)
+ ("7" . index-search)
+ ("8" . telnet)
+ ("9" . binary) ;; must read to end of file
+ ("+" . redundant-server)
+ ("T" . tn3270-session)
+ ("g" . gif)
+ ("I" . image))))
+ (or (alist-ref str mapping-table equal?) 'unknown)))
+
+(define (string->entry str)
+ (condition-case
+ (let* ((s (string-split str tab #t))
+ (type (string->type (string-take (car s) 1)))
+ (title (string-drop (car s) 1))
+ (selector (second s))
+ (host (third s))
+ (port (string->number (fourth s)))
+ (rest (cdddr s)))
+ (make-entry type title selector host port rest))
+ (e () (make-entry 'error "Malformed entry, please ignore" "" "" "" '()))))
+
+(define (render-entry e)
+ (match (entry-type e)
+ ('info
+ (sprintf "~a" (entry-title e)))
+ ('error
+ (sprintf "[ERROR]:\t~a" (entry-title e)))
+ (else
+ (sprintf "\t~a" (entry-title e)))))
+
+(define (call prog r)
+ (with-output-to-pipe prog (lambda () (display r))))
+
+(define history '())
+
+(define (current-page)
+ (if (null? history)
+ #f
+ (car history)))
+
+(define (previous-page)
+ (when (< 1 (length history))
+ (pop! history))
+ (current-page))
+
+(define (get-indices lst pred)
+ (let loop ((l lst)
+ (r '())
+ (i 0))
+ (if (not (pair? l)) (reverse r)
+ (if (pred (car l))
+ (loop (cdr l) (cons i r) (add1 i))
+ (loop (cdr l) r (add1 i))))))
+
+(define (render-directory strs)
+ (let* ((p (map string->entry strs))
+ (links (get-indices p (lambda (e) (not (equal? (entry-type e) 'info))))))
+ (pager p win: (main-win) renderer: render-entry use-cursor: (not (null? links)) selectables: links)))
+
+(define nop values)
+
+(define type-handlers
+ `((file . ,(lambda (c) (pager c win: (main-win)) (previous-page)))
+ (directory . ,render-directory)
+ (index-search . ,render-directory)))
+
+(define (save-selector entry content)
+ (let ((filename (string-append "/tmp/" (last (string-split (entry-selector entry) "/")) (if (equal? (entry-type entry) 'gif) ".gif" ""))))
+ (with-output-to-file filename
+ (lambda () (map display content)))
+ (system (string-append "xdg-open file://" filename))))
+
+(define (select-entry e)
+ (when (and (equal? (entry-type e) 'index-search)
+ (= 1) (length (string-split (entry-selector e) "?")))
+ (let* ((query (get-user-input))
+ (old-selector (entry-selector e)))
+ (if (null? query)
+ (select-entry (current-page))
+ (entry-selector-set! e (string-append (car (string-split old-selector "?")) "?" (string-intersperse (string-split query) "+"))))))
+ (unless (equal? e (current-page))
+ (push! e history))
+ (let* ((res (request-resource (entry-host e) (entry-selector e) (entry-port e) (memq (entry-type e) '(dos-archive binary))))
+ (handler (or
+ (alist-ref (entry-type e) type-handlers)
+ (lambda (c) (save-selector e c))))
+ (next (begin
+ (new-status "~a:~a~a" (entry-host e) (entry-port e) (entry-selector e))
+ (handler res))))
+ (new-status "~a" next)
+ (if next
+ (select-entry next)
+ (unless (equal? 'directory (entry-type (current-page)))
+ (select-entry (current-page))))))
+
+(define (index-entry server #!optional (port gopher-port))
+ (make-entry 'directory "" index server port '()))
+
+
+(define (main args)
+ (initscr)
+ (cbreak)
+ (keypad (stdscr) #t)
+ (curs_set 0)
+ (clear)
+ (refresh)
+ (noecho)
+ (set-signal-handler! signal/winch (lambda (sig) (refresh)))
+ (let-values (((l c) (getmaxyx (stdscr))))
+ (main-win (newwin (sub1 l) c 0 0))
+ (status-win (newwin 1 c (sub1 l) 0))
+ (new-status "Starting up!")
+ (select-entry (index-entry (car args)))
+ (exit 0)))
+
+(exit-handler (lambda code (endwin)))
+(main (command-line-arguments))
(DIR) diff --git a/ncurses-trunk.diff b/ncurses-trunk.diff
@@ -0,0 +1,20 @@
+Index: ncurses.scm
+===================================================================
+--- ncurses.scm (revision 34695)
++++ ncurses.scm (working copy)
+@@ -65,6 +65,7 @@
+ mvaddnstr
+ mvwaddstr
+ mvwaddnstr
++ mvwchgat
+ waddnstr
+ waddstr
+ clear
+@@ -511,6 +512,7 @@
+ (def err mvaddnstr int int c-string int)
+ (def err mvwaddstr win int int c-string)
+ (def err mvwaddnstr win int int c-string int)
++(def err mvwchgat win int int int int short c-pointer)
+ (def err waddnstr win c-string int)
+ (def err waddstr win c-string)
+ (def err clear)
(DIR) diff --git a/proxy.scm b/proxy.scm
@@ -0,0 +1,88 @@
+(module socksv5-proxy
+
+ (connect/socksv5)
+
+ (import chicken scheme foreign)
+ (use tcp srfi-4 srfi-13 bitstring)
+
+ (define (raise-error loc subtype msg . args)
+ (signal (make-composite-condition
+ (make-property-condition 'exn 'message msg 'location loc 'arguments args)
+ (make-property-condition 'i/o)
+ (make-property-condition 'net)
+ (make-property-condition 'socksv5-proxy 'type subtype))))
+
+ (define connect-response-strings
+ '("Succeeded"
+ "General SOCKS server failure"
+ "Connection not allowed by ruleset"
+ "Network unreachable"
+ "Connection refused"
+ "TTL Expired"
+ "Command not supported"
+ "Address type not supported"))
+
+ (define (connect-response->string response-type)
+ (if (> (length connect-response-strings) response-type)
+ (list-ref connect-response-strings response-type)
+ "unassigned"))
+
+ (define (connect/socksv5 proxy proxy-port destination destination-port)
+ (parameterize ((tcp-connect-timeout #f)
+ (tcp-read-timeout #f))
+ (let-values (((i o) (tcp-connect proxy proxy-port)))
+ (write-u8vector '#u8(5 1 0) o)
+ (let ((r (read-u8vector 2 i)))
+ (unless (equal? r '#u8(5 0))
+ (close-input-port i)
+ (close-output-port o)
+ (raise-error 'connect/socksv5 'auth "Unsupported authentication for proxy " r))
+ (write-u8vector
+ (bitstring->u8vector
+ (bitconstruct
+ (5 8) ; Version
+ (1 8) ; connect
+ (0 8) ; reserved
+ (3 8) ; FQDN, do the resolution for us
+ ((string-length destination) 8)
+ (destination bitstring)
+ (destination-port 16 big)))
+ o)
+ (flush-output o)
+ (let* ((resp (read-u8vector 10 i))
+ (response
+ (bitmatch resp
+ (((Version 8)
+ (Reply-field 8)
+ (Reserved 8)
+ (Address-Type 8)
+ (check (= Address-Type 1))
+ (bind-address 32 bitstring)
+ (bind-port 16 big))
+ (list Version Reserved Reply-field Address-Type (bitstring->u8vector bind-address) bind-port))
+ (((Version 8)
+ (Reply-field 8)
+ (Reserved 8)
+ (Address-Type 8)
+ (check (= Address-Type 4))
+ (bind-address 64 bitsring)
+ (bind-port 16 big))
+ (list Version Reserved Reply-field Address-Type (bitstring->u8vector bind-address) bind-port))
+ (((Version 8)
+ (Reply-field 8)
+ (Reserved 8)
+ (Address-Type 8)
+ (check (= Address-Type 3))
+ (bind-address-length 8)
+ (bitmatch (read-u8vector (- (+ bind-address-length 2) 4) i)
+ (((bind-address (* 8 bind-address-length) bitstring)
+ (bind-port 16 big))
+ (list Version Reserved Reply-field Address-Type (bitstring->list bind-address) bind-port)))))
+ (else (raise-error 'connect/socksv5 'connect "Parse error in socket response " resp)))))
+ (if (zero? (cadr response)) ; if reply field is zero all is well
+ (values i o response)
+ (begin
+ (close-input-port i)
+ (close-output-port o)
+ (raise-error 'connect/socksv5 'connect "Connect error" (connect-response->string (car response)))))))))))
+