+++ /dev/null
-133.133.133.133 20:ff:00:00:00:00
-133.133.0.133 20:ff:00:00:00:02
+++ /dev/null
-#!/usr/bin/newlisp
-# Copyright 2017, Ralph Ronnquist <ralph.ronnquist@gmail.com>
-
-;; This program iplements arp responding for selected IP and
-;; interfaces. It listens to network traffic on a given tap, then
-;; responds to any arp requests as per its configuration.
-;;
-;; Usage: -t <tap> <conf>
-;; where <tap> is the tap to service, and <conf> is the pathname for
-;; the configuration file.
-;;
-;; The configuration file has lines of "IP MAC whatever"; other lines
-;; are ignored (as comments).
-
-# Exit on INT, i.e., ^C
-(signal 2 (fn (x) (exit 0)))
-
-# The following library path is for Devuan GNU+Linux
-(constant 'LIBC "/lib/x86_64-linux-gnu/libc.so.6")
-(import LIBC "ioctl" "int" "int" "long" "void*" )
-(import LIBC "perror" "void" "char*" )
-(import LIBC "ntohs" "int" "int" )
-(import LIBC "htons" "int" "int" )
-
-# Report low level system error and exit
-(define (die s) (perror s) (exit 1))
-
-# Tell about usage and exit with error.
-(define (usage)
- (write-line 2 [text];; Usage: -t <tap> <conf>
-;; where <tap> is the tap to service, and <conf> is the pathname for
-;; the configuration file.
-[/text]
- )
- (exit 1))
-
-# Pick up tap name and handled IP from the command line, open
-# the "tun" device (Devuan GNU+Linux), and initialize it for using the
-# given tap name as a tap (not a tun), without packet wrapping.
-(constant 'CMDARG (if (match '(* "-t" ? ?) (main-args)) (1 $it) nil))
-(when (null? CMDARG) (usage))
-
-(constant
- 'IFNAME (CMDARG 0)
- 'IFD (open "/dev/net/tun" "u")
- )
-
-(unless (number? IFD)
- (die "open"))
-(unless (zero? (ioctl IFD 0x400454ca (pack "s16 u s22" IFNAME 0x1002 "")))
- (die (string "set " IFNAME)))
-
-# Set up the IP map
-(define MAP:MAP nil)
-(define (decimal x) (int x 0 10))
-(define (hexadecimal x) (int x 0 16))
-(dolist (X (parse (read-file (CMDARG 1)) "\n"))
- (when (regex "^\s*([0-9\.]+)\\s+([0-9a-fA-F:]+)" X 0)
- (let ((IP $1) (MAC $2))
- (MAP (string (map decimal (parse IP ".")))
- (map hexadecimal (parse MAC ":")))
- )))
-
-# Pack a pair og bytes into a 16-bit number
-(define (b2u x) (+ (<< (x 0) 8) (x 1)))
-
-# Unpack a short number into two bytes in network order
-(define (stonb x) (list (& 0xFF (>> x 8)) (& 0xFF x)))
-
-# Unpack a 32-bit number into two 16-bit in network order
-(define (n2u x) (list (& 0xFFFF (>> x 16)) (& 0xFFFF x)))
-
-# Compute 16 bit checksum of a small even number of bytes
-(define (checksum bytes)
- (apply + (n2u (- (apply + (map b2u (explode bytes 2)))))))
-
-# Pack a byte sequence into a string
-(define (pack-bytes bytes) (pack (dup "b" (length bytes)) bytes))
-
-# Join IP address bytes into a dotted quad string.
-(define (pack-ip x) (join (map string x) "."))
-
-# Process an IPv4 header byte sequence without checksum by inserting one.
-(define (ipv4-header-checksum h)
- (flat (list (0 10 h) (stonb (checksum h)) (10 h))))
-
-# Process an ICMP header byte sequence without checksum by inserting one.
-(define (icmp-header-checksum t c tail)
- (let ((data (unpack (dup "b" (length tail)) tail)))
- (flat (list t c (stonb (checksum (flat (list t c data)))) data))))
-
-# ARP request handler. Confirms the targeted IP address is one to
-# handle and then issues a corresponding reply. Note: the MAC address
-# is formed from the IP address.
-(define (arp-request-handler) ; buffer
- (letn ((IP (unpack "bbbb" (38 buffer)))
- (MYMAC (flat (list 2 IP 2)))
- (MAPMAC (MAP (string IP))))
- (when MAPMAC
- (write IFD (pack "bbbbbb bbbbbb u u u b b u bbbbbb bbbb bbbbbb bbbb"
- (flat (list (unpack "bbbbbb" (6 buffer))
- MYMAC (map htons '(0x0806 0x1 0x0800 ))
- 0x06 0x04 (htons 0x2) MAPMAC IP
- (unpack "bbbbbb bbbb" (22 buffer))
- ))
- )))))
-
-# ARP packet handler. Recognizes the ARP command involved, and for
-# some of them, it dispatches to the associated handler, if any.
-(define (arp-handler) ; buffer
- (case (ntohs ((unpack "u" (20 buffer)) 0)) ; ARP command
- (0x0001 (and arp-request-handler (arp-request-handler)))
- (true nil) ; ignore
- ))
-
-# ICMP request handler. Confirms that the targeted IP is one to
-# handle, and then issues a corresponding response.
-(define (icmp-request-handler)
- (letn ((h (unpack "bbbb bbbb" (26 buffer)))
- (n (ntohs((unpack "u" (16 buffer)) 0)))
- (MYMAC (MAP (string (4 4 h)))) )
- (when MYMAC
- (write IFD
- (pack-bytes
- (flat (list
- # Ethernet header (14 bytes)
- (unpack "bbbbbb" (6 buffer))
- MYMAC
- (stonb 0x0800) ; Type = IPv4
- # IPv4 header (20 bytes, with header checksum)
- (ipv4-header-checksum
- (flat (list 0x45 0 0 n
- (unpack "bbbbbb" (18 buffer))
- (4 4 h) (0 4 h))))
- # ICMP header
- (icmp-header-checksum 0 0 ((+ ihl 18) buffer))
- ))
- ))
- )))
-
-# ICMP packet handler. Recognizes the ICMP type involved and for some
-# of them, it dispatches to the associated handler, if any.
-(define (icmp-handler)
- (case ((unpack "b" ((+ ihl 14) buffer)) 0)
- (8 (and icmp-request-handler (icmp-request-handler)))
- (true)))
-
-# IPv4 packet handler. Recognises the IPv4 protocol involved, and for
-# some of them, it dispatches to the associated handler, if any.
-(define (ipv4-handler) ; buffer
- (let ((ihl (* (& 0x0F ((unpack "b" (14 buffer)) 0)) 4)))
- (case ((unpack "b" (23 buffer)) 0) ; protocol
- (0x01 (and icmp-handler (icmp-handler)))
- (0x02 (and igmp-handler (igmp-handler)))
- (0x04 (and ipip-handler (ipip-handler)))
- (0x06 (and tcp-handler (tcp-handler)))
- (0x11 (and udp-handler (udp-handler)))
- (true nil) ; ignore
- )
- ))
-
-# Ethernet packet handler. Recognises EtherTYpe involved, and for some
-# of them, it dispatches to the associated handler, if any.
-(define (handle-packet) ; buffer
- (when (> n 14)
- (case (ntohs ((unpack "u" (12 buffer)) 0)) ; Ethertype
- (0x0806 (and arp-handler (arp-handler)))
- (0x0800 (and ipv4-handler (ipv4-handler)))
- ;(0x86DD (and ipv6-handler (ipv6-handler)))
- (true nil) ; ignore all else
- )))
-
-# Tap handler. Reads an Ethernet packet from the tap, and invokes the
-# associated handler.
-(define (handle-tap)
- (let ((buffer "") (n nil))
- (if (setf n (read IFD buffer 8000)) (handle-packet)
- (die (string "** error reading " IFNAME)))))
-
-# Input handler. Waits for input on the tap or stdin, and invokes the
-# associated handler. This is set up as a prompt-event handler, so as
-# to multiplex tap handling with newlisp interactive command handling.
-(define (ioselect s)
- (letn ((fds (list 0 IFD)) (fdx nil))
- (until (member 0 (setf fdx (or (net-select fds "r" 10000000) '())))
- (when fdx (handle-tap))))
- nil)
-
-# "Main program" starts here
-(println "IP addresses on " IFNAME ":")
-(map println (MAP))
-(prompt-event ioselect)
-(reset)
+++ /dev/null
-= arper.lsp(8)
-:doctype: manpage
-:revdate: {sys:date "+%Y-%m-%d %H:%M:%S"}
-:COLON: :
-:EQUALS: =
-
-== NAME
-
-arper.lsp - Emulate ipv4 presence on a tap by responding to ARP and ICMP.
-
-== SYNOPSIS
-
-*./arper.lsp* *-t* _tap_ _conf__
-
-== DESCRIPTION
-
-The *arper.lsp* program implements ARP and ICMP responding on a given
-_tap_ interface for a selection of ipv4 addresses as specified in the
-given configuration file. This emulates the presence of one or more
-ipv4 hosts, as if the _tap_ was interfacing a network.
-
-The configuration file has lines of "ipv4 mac comment" to declare
-pairs of IP and MAC addresses to emulate.
-
-Note that the _tap_ must be configured separately.
-
-== EXAMPLE
-
-=== Emulating a single host
-
-The configuration, "single", is as follows:
-----
- 192.168.1.2 02:00:00:00:00:02 some "random" host
-----
-
-Commandline:
-----
-# ./arper.lsp -t tap0 single &
-# ifconfig tap0 192.168.1.1/24 up
-# ping -n 192.168.1.2
-# fg^C
-----
-
-=== Emulating three host on local network
-
-The configuration, "triple", is as follows:
-----
- 192.168.1.2 02:00:00:00:00:02 some "random" host
- 192.168.1.20 02:00:00:00:00:02 another "random" host
- 192.168.1.200 02:00:00:00:00:02 and another "random" host
-----
-
-Commandline:
-----
-# ./arper.lsp -t tap0 single &
-# ifconfig tap0 192.168.1.1/24 up
-# ping -c 3 -n 192.168.1.2
-# ping -c 3 -n 192.168.1.20
-# ping -c 3 -n 192.168.1.22
-# ping -c 3 -n 192.168.1.200
-# fg^C
-----
-
-Note that +192.168.1.22+ is not emulated.
-
-=== Emulating hosts on several network
-
-The configuration, "triss", is as follows:
-----
- 192.168.1.2 02:00:00:00:00:02 some "random" host
- 192.168.2.2 02:00:00:00:00:02 another "random" host
- 192.168.3.2 02:00:00:00:00:02 and another "random" host
-----
-
-Commandline:
-----
-# ./arper.lsp -t tap0 single &
-# ifconfig tap0 192.168.1.1/24 up
-# ip addr add 192.168.2.1/24 dev tap0
-# ip addr add 192.168.3.1/24 dev tap0
-# ping -c 3 -n 192.168.1.2
-# ping -c 3 -n 192.168.2.2
-# ping -c 3 -n 192.168.3.2
-# fg^C
-----
-
-=== NOTES
-
-The *arper.lsp* script is prepared for handling ipv6 packets, but it
-does not include any Neighbor Discovery activity.
-
-== AUTHOR
-
-Copyright 2021 Ralph Ronnquist <ralph.ronnquist@gmail.com>
+++ /dev/null
-;; Utility module for coprocesses in newlisp
-;;
-;; This is a convenience implementation for running a sub process with
-;; its stdio via pipes. It is somewhat similar to the standard
-;; <process> function but the <coproc> utility combines the process
-;; PID together with its stdin/stdout into a FOOP object for onwards
-;; interactions. The <coproc> command is passed as a command line to
-;; /bin/sh and allows passing in environment. Further, the startup
-;; includes closing the unused file descriptors.
-;;
-;; @syntax: (coproc cmd [ env ] )
-;; Start a coprocess and returns its representation which is a FOOP
-;; object: ([coproc] PID outfd infd)
-;;
-;; The given <cmd> command is passed to "sh -c 'cmd'" sub process
-;; through a fork+execve scheme. The <env> argument should be a
-;; pointer to a null-terminated array of pointers to environment
-;; NUL-terminated strings of format "NAME=VALUE". (The caller must
-;; take care of providing existing pointers.
-;;
-;; @syntax: (:put0 coproc str )
-;; Write <str> to the given <coproc>. Returns the number of bytes
-;; written.
-;;
-;; @syntax: (:puts coproc str )
-;; Write <str> followed by newline to the given <coproc>. Returns the
-;; number of bytes written.
-;;
-;; @syntax: (:gets coproc [ limit [ waitms ]] )
-;; Read one line from the given <coproc> or up to <limit> bytes
-;; (default 100000) with up to <waitms> millisceonds delay (default
-;; 100) before reading.
-;;
-;; @syntax: (:pug coproc str [ limit [ waitms ]] )
-;; Write <str> with :puts, then read once with :gets and return that.
-;;
-;; @syntax: (:pugs coproc str [ limit [ waitms ]] )
-;; Write <str> with :puts, then read repeatedly with :gets collating
-;; its returned lines into a list until :gets retuns nil. Returns the
-;; list of lines.
-;;
-;; @syntax: (:running? coproc [ timeout ])
-;; Check if coproc is running, i.e., that its stdin is still open.
-
-(context 'coproc)
-
-(constant 'LIBC6 "/lib/x86_64-linux-gnu/libc.so.6")
-(import LIBC6 "execve" "int"
- "void*" ; pathname
- "void*" ; argv[]
- "void*" ; env[]
- )
-(import LIBC6 "dup2" "int"
- "int" ; oldfd
- "int" ; newfd
- )
-(import LIBC6 "poll" "int"
- "void*" ; struct pollfd *fds
- "int" ; nfds_t nfds
- "int" ; timeout
- )
-
-(constant 'F_GETFD 1)
-
-; <environ> is a 64-bit char** variable, rather than a function
-(import LIBC6 "environ")
-
-; Return the 64-bit value of environ
-(define (environ@) ((unpack "Lu" (address environ)) 0))
-
-; Pack a list of void* pointers into an array with a final null
-; pointer added.
-(define (pack-ptrs PTRS)
- (pack (dup "Lu" (+ 1 (length PTRS))) (append PTRS (list 0))))
-
-; Prepare the binary data setup for calling execve to execute <cmd>
-; via "sh -c 'exec <cmd>'" and the given environment <ENV>. If <ENV>
-; is <true>, then the current process environment is used, otherwise
-; it should be a list of name-value pairs (strings).
-(define (wrapper cmd IO ENV)
- (letn ((ARGS (list "/bin/sh" "-c" (string "exec " cmd)))
- (ARGV (pack-ptrs (find-all nil ARGS (address $it) !=)))
- (EV (if (list? ENV) (map (curry format "%s=%s") ENV)))
- (ENVP (if (= true ENV) (environ@)
- EV (pack-ptrs (find-all nil EV (address $it) !=))))
- )
- (map dup2 (list (IO 0 0) (IO 1 1) (IO 1 1)) '(0 1 2))
- (map close (flat IO))
- (execve "/bin/sh" ARGV (or ENVP 0))
- (exit 1)))
-
-; Create a coproc FOOP object which holds PID and pipe ends.
-(define (coproc:coproc cmd ENV)
- (let ((IO (list (pipe) (pipe))))
- (list (context)
- (fork (wrapper cmd IO ENV))
- (begin (close (IO 0 0)) (close (IO 1 1)) (IO 0 1))
- (IO 1 0))))
-
-; Wait up to <waitms> for input from the coproc, then read one line of
-; up to <limit> bytes and return. The final newline, if any, is
-; chopped off.
-(define (gets limit waitms)
- (let ((buffer "")
- (delay (if (number? waitms) (* waitms 1000) 100000))
- (maxsize (if (number? limit) limit 1000000))
- )
- (and (net-select (self 3) "r" delay)
- (read (self 3) buffer maxsize "\n")
- (if (empty? buffer) buffer
- (!= "\n" (buffer -1)) buffer
- (chop buffer))
- )))
-
-; Write <str> to the coproc.
-(define (put0 str)
- (write (self 2) str (length str)))
-
-; Write <str> to the coproc plus a newline.
-(define (puts str)
- (write-line (self 2) str (length str)))
-
-; First :puts, then :gets
-(define (pug str limit waitms) (puts str) (gets limit waitms))
-
-; First :puts, then collect :gets until nil
-(define (pugs str limit waitms) (puts str) (collect (gets limit waitms)))
-
-; Poll the stdin pipe
-(define (running? (timeout 1))
- (let ((FDS (pack "Lu" (self 2))))
- (>= 0 (poll FDS 1 timeout))))
+++ /dev/null
-#!/usr/bin/newlisp
-#
-# Helper tool to browse and edit the ifupdown configuration
-# uses iselect, ed, nano and sudo
-#
-# Extra iselect commands:
-# # = toggle commenting of configuration block
-# d = delete empty line
-# e = edit the whole file
-#
-# right-arrow or return = follow to sourced file, or edit the current block
-# left-arrow or q = go up or exit
-
-(signal 2 (fn (x) (exit)))
-
-(when (!= "0" (if (exec "id -u") ($it 0) ""))
- (let ((SUDO (if (exec "command -v sudo") ($it 0) "/usr/bin/sudo"))
- (ED (format "env EDITOR=%s" (or (env "EDITOR") "nano"))) )
- (wait-pid (process (join (flat (list SUDO ED (main-args))) " ")))
- (exit 0)))
-
-(constant
- ;; all "block starters", including blank lines
- 'ENI-KEY '( "iface" "mapping" "auto" "allow-\\w*" "rename"
- "source" "source-directory" "$")
- ;; regex to identify block starters
- 'ENI-HEAD (format "^\\s*#?\\s*(%s)" (join ENI-KEY "|"))
- 'ENI-COMMENT "^\\s*#"
- 'EDITOR (or (env "EDITOR") "nano")
- 'PROC (if (exec (format "command -v %s" EDITOR)) ($it 0) "/bin/nano")
- )
-
-(define (is-eni-key PAT S)
- (when (regex PAT S 0) true))
-
-(define (is-eni-comment S)
- (is-eni-key ENI-COMMENT S))
-
-(define (istrue? A B)
- (list A B) (= A B true))
-
-(define (eni-starters) ; DATA
- (flat (ref-all ENI-HEAD DATA is-eni-key)))
-
-;; Pull out the block headed by the B line. If this head is a blank
-;; line, then the block includes preceeding comment and the blank line
-;; only. Otherwise it includes preceeding comment, head line and the
-;; following mix of non-head lines and comment lines (i.e. up to next
-;; head line). FROM is the line after the prior block, and it is moved
-;; to end of this block.
-(define (sub-divide-DATA B (E (length DATA))) ; DATA FROM
- (let ((SLICE (fn (F B E) (append (list F B E) (slice DATA F (- E F))))))
- (SLICE FROM B (set 'FROM (if (empty? (DATA B)) (+ B 1) E)))))
-
-;; Read the "interfaces file" and split up into its "blocks"
-;; <block> <commentline>* <headline> ( <otherline> | <commentline> )*
-(define (read-eni NAME)
- (letn ((DATA (parse (read-file NAME) "\n"))
- (BEG (eni-starters))
- (FROM 0))
- (setf LASTENI (map sub-divide-DATA BEG (1 BEG)))
- ;;(map println LASTENI)
- ;;(read-line)
- LASTENI
- ))
-
-(define (add-selector X)
- (cons (format "<s:%d>%s" (X 0) (X 1)) (2 X)))
-
-;; Find the definition block spanning line I in file FILE
-(define (find-block I FILE)
- ;;(println (list 'find-block I FILE))
- (exists (fn (B) (< I (B 2))) (read-eni FILE)))
-
-############################################################
-### Interactive actions
-
-## PATH holds interactive state as a stack of [pos file]
-(setf PATH '(( 0 "/etc/network/interfaces" )) )
-
-; Edit a file
-(define (edit-file I FILE)
- (wait-pid (process (format "%s +%d %s" PROC (int I) FILE))))
-
-(define (ensure-newline TXT)
- (if (empty? TXT) "" (ends-with TXT "\n") TXT (string TXT "\n")))
-
-(define (update-file B E TXT FILE)
- (let ((DATA (parse (read-file FILE) "\n")))
- (write-file TXT (string (join (0 B DATA) "\n" true)
- (ensure-newline (read-file TXT))
- (join (E DATA) "\n")))
- (exec (format "mv %s %s" TXT FILE))
- ))
-
-(define (key-command-select I FILE) ; PATH
- (letn ((BLOCK (find-block (- (int I) 1) FILE))
- (TMP "/tmp/enitool/tmp.conf")
- (HEAD (BLOCK (- (BLOCK 1) (BLOCK 0) -3)))
- (TAG (or (and (regex "^#?(\\w*) (.*)" HEAD 0) $1) "#"))
- (VALUE $2))
- (case TAG
- ("source" (push (list 0 VALUE) PATH))
- (true (write-file TMP (join (3 BLOCK) "\n" true))
- (let ((F (file-info TMP 6)))
- (edit-file 1 TMP)
- (when (!= F (file-info TMP 6))
- (update-file (BLOCK 0) (BLOCK 2) TMP FILE)))
- ))
- ))
-
-(define (delete-block-maybe I FILE)
- (let ((BLOCK (find-block (- (int I) 1) FILE))
- (TMP "/tmp/enitool/tmp.conf"))
- (when (= (3 BLOCK) '(""))
- (exec (format "ed -s %s" FILE)
- (format "%dd\nw\n" (+ 1 (BLOCK 0)))))))
-
-(define (toggle-commenting I FILE)
- (let ((BLOCK (find-block (- (int I) 1) FILE))
- (TMP "/tmp/enitool/tmp.conf"))
- (letn ((H (- (BLOCK 1) (BLOCK 0)))
- (TXT (3 BLOCK))
- (toggle (if (starts-with (TXT H) "#")
- (fn (X) (if (starts-with X "#") (1 X) X))
- (fn (X) (string "#" X)))))
- (write-file TMP (ensure-newline
- (string (join (0 H TXT) "\n" true)
- (join (map toggle (H TXT)) "\n"))))
- (update-file (BLOCK 0) (BLOCK 2) TMP FILE)
- )))
-
-(define (command-dispatch CMD FILE)
- (when (regex "([^:]+):([^:]+):(\\S*)\\s*(.*)" CMD 0)
- (setf (PATH 0 0) (int $1))
- (cond
- ((member $2 '("KEY_RIGHT" "RETURN")) (key-command-select $1 FILE))
- ((= $2 "d") (delete-block-maybe $1 FILE))
- ((= $2 "#") (toggle-commenting $1 FILE))
- ((= $2 "e") (edit-file $1 FILE))
- )))
-
-(define (iselect POS FILE)
- (exec (format "iselect -n '%s' -t '%s' -a -P -K '-k#' -kd -ke -p %d < %s"
- "enitool" FILE (int POS) FILE)))
-
-(change-dir "/etc/network")
-(make-dir "/tmp/enitool")
-
-(while PATH
- (if (apply iselect (PATH 0))
- (command-dispatch ($it 0) (PATH 0 1))
- (pop PATH)))
-
-(exit 0)
+++ /dev/null
-hobby-http.lsp
-==============
-
-This script utilizes newlisp's built-in HTTP service for serving a
-directory tree. Run as
-
- $ newlisp hobby-http.lsp -c -http -d $PORT -w $ROOT
-
-It limits to handling GET and HEAD requests.
-
-See http://www.newlisp.org/downloads/manual_frame.html for details on
-newlisp.
-
+++ /dev/null
-#!/usr/bin/newlisp
-#
-# Simple HTTP service for a directory tree. Start with:
-#
-# newlisp hobby-http.lsp -c -http -d $PORT -w $TREE
-#
-# Note that it does not make automatic file indexes of directories,
-# and it only shows the files that are there. Some files are handled
-# by their file extension, such as: .avi, .cgi, .css, .gif, .htm,
-# .html, .jpg, .js, .mov, .mp3,.mpg, .pdf, .png, .wav, .zip. Those
-# files are served with appropriate mime types, except .cgi which if
-# executable will be executed as a near CGI 1.1 script. Other files
-# are served with type "text/plain".
-
-; Exit on ^C -- not cleanly
-(signal 2 (fn (x) (write-line 2 "Exiting") (close 3) (exit 0)))
-
-; Resolve the root path
-(constant 'HERE (real-path ((match '(* "-w" ? *) (main-args)) 1)))
-
-; Map absolute path
-(define (actual PATH)
- (if (starts-with PATH "/") (string HERE PATH) PATH))
-
-; Rewriting rules: add ".html" or "/index.html" to request path where
-; that results in an actual file.
-(define (maybe-html PATH)
- (let ((P0 (actual PATH)) (HTML nil))
- (if (find ".." PATH) PATH
- true
- (if (file? (string P0 ".html")) (string PATH ".html")
- (file? (string P0 "/index.html"))
- (string PATH (if (ends-with PATH "/") "" "/") "index.html")
- PATH )
- PATH )))
-
-; Apply rewriting rules for some requests
-(define (tag-on-html X)
- (write-line 2 (string "> " X ))
- (setf X (if (and (string? X) (regex "^([^\\s]+) ([^ ]+) (.+)" X 0))
- (let ((A $1) (B $2) (C $3))
- (format "%s %s %s\r\n" A (maybe-html B) C) X)))
- (write-line 2 (string "< " X))
- X)
-
-(define (filter-request X)
- (if (starts-with X "(GET|HEAD)" 0) (tag-on-html X)
- "GET /403.html HTTP/1.1"))
-
-(command-event filter-request)
+++ /dev/null
-#!/usr/local/bin/newlisp
-#
-# Stream filter that reads css and writes it out, stylished. run with
-#
-# newlisp humancss.lsp < bad.css > good.css
-#
-# Not actually pretty-printing, but merely adding indentation and newlines.
-
-;(signal 2 (fn (x) (exit 0)))
-
-(setf IN '())
-
-;; Load the CSS file as an array of single-character strings
-(while (setf LINE (read-line)) (extend IN (explode LINE) '("\n")))
-(setf IN (array (length IN) IN)) ; This should speed of indexed access
-(setf LAST (- (length IN) 1))
-
-;; Coalsce comments and strings into units
-(define (coalesce START END) ; exclusive
- (when (< END (length IN))
- (setf (IN START) (join (array-list (START (- END START) IN))))
- (while (< (inc START) END) (setf (IN START) ""))))
-
-(define (coalesce-block-comment i)
- (let ((STAR nil) (END nil))
- (for (j (+ 2 i) LAST 1 END)
- (if STAR (if (= "/" (IN j)) (setf END j) (setf STAR nil))
- (= "*" (IN j)) (setf STAR true)))
- (when END (coalesce i (+ 1 END)))))
-
-(define (coalesce-line-comment i)
- (let ((END (find "\n" IN nil i)))
- (when END (coalesce i (+ 1 END)))))
-
-(define (index-of-any OPTS START)
- (if (> START LAST) nil
- (if (find OPTS (START IN) (fn (X Y) (member Y X))) (+ START $it))))
-
-(define (coalesce-string i) ; (IN i) is the string character
- (let ((END nil))
- (for (j (+ 1 i) LAST 1 END)
- (if (= "\\" (IN j)) (coalesce j (+ 2 j))
- (= (IN i) (IN j)) (setf END (+ 1 j))))
- (when END (coalesce i END))))
-
-; Coalesce comments, meta-quotes and strings
-(let ((SLASH nil))
- (for (i 0 LAST)
- (if (= "\\" (IN i)) (begin (coalesce i (+ 2 i)) (setf SLASH nil))
- SLASH (begin (case (IN i)
- ("*" (coalesce-block-comment (- i 1)))
- ("/" (coalesce-line-comment (- i 1)))
- (true nil))
- (setf SLASH nil))
- (= "/" (IN i)) (setf SLASH true)
- (= "\"" (IN i)) (coalesce-string i)
- (= "'" (IN i)) (coalesce-string i)
- )))
-
-(define (indent TXT n)
- (join (clean empty? (parse TXT "\n")) (string "\n" (dup " " n))))
-
-; Coalesce blocks recursively, adding a newline to it
-(define (coalesce-block i (DEPTH 0))
- ;(write-line 2 (string "block level " DEPTH " from " i))
- (let ((j 0) (END nil))
- (for (j (+ 1 i) LAST 1 END)
- (case (IN j)
- ("{" (coalesce-block j (+ 1 DEPTH)))
- ("}" (setf END j))
- (true nil)))
- (when END
- (setf (IN i) " {\n")
- (coalesce i END)
- (setf (IN i) (indent (IN i) DEPTH))
- (extend (IN i) (if (ends-with (IN i) "\n") "}\n" "\n}\n"))
- (setf (IN END) "")
- )))
-
-(for (i 0 LAST) (when (= ";" (IN i)) (setf (IN i) ";\n")))
-
-(for (i 0 LAST) (when (= "{" (IN i)) (coalesce-block i 1)))
-
-(write 1 (join (array-list IN)))
-
-(exit 0)
+++ /dev/null
-#!/usr/local/bin/newlisp
-# Copyright 2018, Ralph Ronnquist <ralph.ronnquist@gmail.com>
-
-; This newlisp script is a "daemon" to make the right-hand monitor (in
-; a horizontal Xinerama set up) "sticky". The script listens to X
-; events so as to discover that a window is moved, and acts on it when
-; it's placed. Specifically, when a window is placed to the right of
-; the EDGE, it is pinned to be on all workspaces, and when it's placed
-; to the left of the EDGE, it's unpinnned to be on the current
-; workspace only.
-;
-; https://tronche.com/gui/x/xlib/
-; http://refspecs.linuxfoundation.org/LSB_3.1.1/LSB-Desktop-generic/LSB-Desktop-generic/libx11-ddefs.html
-; https://specifications.freedesktop.org/wm-spec/1.3/index.html
-; https://www.x.org/archive/X11R7.7/doc/man/man3/Xinerama.3.xhtml
-
-; Set up to die on ^C
-(define (die x) (exit 0)) (signal 2 die)
-
-; Utility to return the first of a series of terms.
-(define (prog1) (args 0))
-
-; Read macro for the address at a byte offset <N> into block <P>.
-(macro (p@ P N) (+ (address P) N))
-
-; Utility to unpack a packed binary array at <p> of <n> layout <s>
-; records with <w> fields each.
-(define (unpack-array s w n p) (explode (unpack (dup s n) p) w))
-
-; Making them available in all contexts.
-(global 'prog1 'p@ 'unpack-array)
-
-(context 'MAIN:X11) ; API for libX11.so
-(constant 'LIB "/usr/lib/x86_64-linux-gnu/libX11.so") ; Devuan 2.0
-
-(import LIB "XDefaultRootWindow" "void*"
- "void*" ; display
- )
-(import LIB "XFree" "void"
- "void*" ; data
- )
-(import LIB "XGetWindowProperty" "int"
- "void*" "void*" "long" ; display, window, property(atom)
- "long" "long" "int" "long" ; long_offset, long_length, delete, req_type
- "void*" "void*" ; actual_type_return, actual_format_return
- "void*" "void*" ; nitems_return, bytes_after_return
- "void*" ; prop_return
- )
-(struct 'XGetWindowProperty_return
- "long" ; actual_type_return
- "int" ; actual_format_return
- "long" ; nitems_return
- "long" ; bytes_after_return
- "void*" ; prop_return
- )
-(import LIB "XInternAtom" "long"
- "void*" "char*" "int" ; display, atom_name, only_if_exists
- )
-(import LIB "XNextEvent" "void"
- "void*" "void*" ; display, window
- )
-(import LIB "XSendEvent" "int"
- "void*" "void*" ; display, window
- "int" "long" "void*"
- )
-(import LIB "XOpenDisplay" "void*"
- "void*" ; display
- )
-(import LIB "XQueryTree" "int"
- "void*" "void*" ; display, window
- "void*" "void*" ; root_return, parent_return
- "void*" "void*" ; children_return, nchildren_return
- )
-(struct 'XQueryTree_return
- "long" "long" ; root_return, parent_return
- "long" "int" ; children_return, nchildren_return
- )
-(import LIB "XSelectInput" "void"
- "void*" "void*" "long" ; display, window, mask
- )
-(struct 'XConfigureEvent
- "int" "long" "int" ; type, serial, send_event
- "void*" "void*" "void*" ; display, event, window
- "int" "int" "int" "int" "int" ; x, y, width, height, border_width
- "void*" "int" ; above, override_redirect
- )
-(struct 'XCrossingEvent
- "int" "long" "int" ; type, serial, send_event
- "void*" "void*" "void*" "void*" ; display, window, root, subwindow
- "long" ; time
- "int" "int" "int" "int" ; x, y, x_root, y_root
- "int" "int" ; mode, detail
- "int" "int" "int" ; same_screen, focus, state
- )
-(struct 'XClientMessageEvent
- "int" "long" "int" ; type, serial, send_event
- "void*" "void*" "void*" "void*" ; display, window
- "long" "int" ; message_type, format
- "long" "long" "long" "long" "long" ; data
- )
-
-; Initializing the X client, and defining some constants.
-(constant
- 'display (XOpenDisplay 0)
- 'root (XDefaultRootWindow display)
- '_NET_CURRENT_DESKTOP (XInternAtom display "_NET_CURRENT_DESKTOP" 1)
- '_NET_WM_DESKTOP (XInternAtom display "_NET_WM_DESKTOP" 1)
- 'LeaveWindowMask (<< 1 5)
- 'SubstructureNotifyMask (<< 1 19)
- 'PropertyChangeMask (<< 1 22)
- 'LeaveNotify 8
- 'ConfigureNotify 22
- )
-
-; Utility wrapping for XNextEvent. The "event" argument is the union
-; of all possible event types, which all fit in a block of 24 long
-; integers (192 bytes).
-(define (nextEvent)
- (let ((e (dup "\000" 192))) (XNextEvent display (p@ e 0)) e ))
-
-; Utility to map an X layer window to its "application window", which
-; is the last child of the X layer window. This uses XQueryTree which
-; has many return values (see XQueryTree_return). Note that the
-; returned children array (r 2) is malloc-ed, and it needs to be
-; XFree-ed.
-(define (app-window w)
- (let ((r (pack XQueryTree_return 0 0 0 0)))
- (when (!= (XQueryTree display w (p@ r 0) (p@ r 8) (p@ r 16) (p@ r 24)))
- (setf r (unpack XQueryTree_return r))
- (prog1 (if (!= (r 3)) ((unpack-array "Lu" 1 (r 3) (r 2)) -1 0))
- (XFree (r 2))))))
-
-; Utility to obtain a long-valued property (atom named) from a window.
-(define (get-property w a)
- (let ((r (pack XGetWindowProperty_return 0 0 0 0 0)))
- (when (XGetWindowProperty display w a 0 1 0 0
- (p@ r 0) (p@ r 8) (p@ r 16) (p@ r 24) (p@ r 32))
- (setf r (last (unpack XGetWindowProperty_return r)))
- (when (!= r) (prog1 ((unpack "ld" r) 0) (XFree r) )))))
-
-; Utility to obtain the current workspace. This is maintained as a
-; property of the root window. (Called "desktop" in ancient times)
-(define (current-workspace) (get-property root _NET_CURRENT_DESKTOP ) )
-
-; Utility to obtain the worskpace property of a window.
-(define (window-workspace w) (and w (get-property w _NET_WM_DESKTOP )) )
-
-; Utility to set the workspace property for a window. Note that the
-; targeted "application window" to pin or unpin is actually a child of
-; the given X layer window (or "window manager window").
-(define (set-window-workspace w dt)
- (let ((aw (app-window w)))
- (and aw (!= dt (window-workspace aw))
- (XSendEvent display root 0 PropertyChangeMask
- (pack XClientMessageEvent 33 0 0 display aw
- _NET_WM_DESKTOP 32 dt 2 0 0 0) )) ))
-
-(context 'MAIN:Xinerama) ; API for libXinerama.so
-(constant 'LIB "/usr/lib/x86_64-linux-gnu/libXinerama.so.1") ; Devuan 2.0
-
-(import LIB "XineramaQueryScreens" "void*" ; XineramaScreenInfo*
- "void*" ; Display *display
- "void*" ; int *number
- )
-(struct 'XineramaScreenInfo
- "int" ; monitor index
- "short int" "short int" "short int" "short int" ; x, y, width, height
- )
-
-; Utility to obtain the list of monitor physical dimensions
-; Returns: ((id x y w h) ... )
-(define (queryScreens)
- (letn ((e (pack "lu" 0))
- (p (XineramaQueryScreens X11:display (p@ e 0)))
- (n ((unpack "lu" e) 0)))
- (when (!= n) (prog1 (unpack-array "luuuuu" 5 n p) (X11:XFree p)))
- ))
-
-(context MAIN) ; ---- The main application starts here ----
-
-(setf
- EDGE ((Xinerama:queryScreens) 0 3) ; width of monitor 0
- window nil ; last moved window and position (id x y)
- )
-
-; Handle XConfigureEvent by capturing window id and top-left
-; coordinates. These events are issued while a window is moved. The
-; last of them thus tells the last placement of the moved window.
-(define (Configure e)
- (setf window (select (unpack X11:XConfigureEvent e) 5 6 7)))
-
-; Handle XCrossingEvent events, identifying the "ungrab event" after
-; having moved a window (i.e., releasing it at its last placement). At
-; then, the most recently moved window is reviewed for placement, and
-; its "workspace placement property" is set depending on where the
-; window is relative to EDGE; either to the current workspace, or to
-; -1, which means "all workspaces".
-(define (Leave e)
- (when (and window (= (& (last (unpack X11:XCrossingEvent e)) 0x100)))
- (X11:set-window-workspace (window 0)
- (if (>= (window 1) EDGE) -1 (X11:current-workspace))) ))
-
- ; Set up to receive certain events only.
-(X11:XSelectInput
- X11:display X11:root (| X11:SubstructureNotifyMask X11:LeaveWindowMask ))
-
-; Handle X events until the cows go home.
-(letex ((L X11:LeaveNotify) (C X11:ConfigureNotify))
- (while (setf e (X11:nextEvent))
- (case ((unpack "lu" e) 0) ; the event type
- ( L (Leave e))
- ( C (Configure e))
- (true nil)) ))
-
-(exit)
+++ /dev/null
-pinwin - making the side monitor sticky
-=======================================
-
-This is a pair of scripts acting as an X event daemon that recognizes
-window movements and "pins" windows when moved to the side monitor,
-whereas windows moved to the main monitor are "unpinned".
-
-A pinned window shows up on all workspaces, whereas an unpinned one
-stays on a single workspace.
-
-I think some window managers might support the "pin windows on side
-monitor" function already, but I couldn't find this for my xfce4.
-
-Note that the newlisp script `pinwin.lsp` implements the assumption
-that the side monitor is to the right of the main monitor. Any other
-set up will require an appropriate adjustment.
-
-BUILD
-=====
-
-Note that daemonizing shell script `pinwin.sh` expects the embedded
-binary, `pinwin`, which is made using the `-x` argument to newlisp. For
-example:
-
- $ newlisp -x pinwin.lsp pinwin
- $ chmod a+x pinwin
-
-RUN
-===
-
-The daemon is run as a detached process. For example:
-
- $ ( ./pinwin.sh & )
+++ /dev/null
-#!/usr/local/bin/newlisp
-# Copyright 2017, Ralph Ronnquist <ralph.ronnquist@gmail.com>
-
-;; This program simulates a remote host or subnet attached to a tap,
-;; responding to ARP and ICMP. It does not configure the tap at all,
-;; but listens to network traffic, and responds to ARP requests and
-;; ICMP requests matching to its IP adresses, given on the commmand
-;; line.
-;;
-;; Usage: newlisp taplet.lsp -t <tap> -ip <ip-list>
-;; where <ip-list> is a comma separated list of IP to handle.
-
-# Exit on INT, i.e., ^C
-(signal 2 (fn (x) (exit 0)))
-
-# The following library path is for Devuan GNU+Linux
-(constant 'LIBC "/lib/x86_64-linux-gnu/libc.so.6")
-(import LIBC "ioctl" "int" "int" "long" "void*" )
-(import LIBC "perror" "void" "char*" )
-(import LIBC "ntohs" "int" "int" )
-(import LIBC "htons" "int" "int" )
-
-# Report low level system error and exit
-(define (die s) (perror s) (exit 1))
-
-# Find a command line argument key and optionally the subsequent
-# value, if a non-nil default value is given.
-(define (mainarg k (v nil))
- (let ((a (member k (main-args))))
- (if (null? a) v (nil? v) true (null? (1 a)) v (a 1))))
-
-# Pick up tap name and handled IP from the command line, open
-# the "tun" device (Devuan GNU+Linux), and initialize it for using the
-# given tap name as a tap (not a tun), without packet wrapping.
-(constant
- 'IFNAME (mainarg "-t" "tap0")
- 'MYIPS (map (fn (ip) (map int (parse ip "."))) (parse (mainarg "-ip" "") ","))
- 'IFD (open "/dev/net/tun" "u")
- )
-(unless (number? IFD) (die "open"))
-(unless (zero? (ioctl IFD 0x400454ca (pack "s16 u s22" IFNAME 0x1002 "")))
- (die (string "set " IFNAME)))
-
-# Pack a pair og bytes into a 16-bit number
-(define (b2u x) (+ (<< (x 0) 8) (x 1)))
-
-# Unpack a short number into two bytes in network order
-(define (stonb x) (list (& 0xFF (>> x 8)) (& 0xFF x)))
-
-# Unpack a 32-bit number into two 16-bit in network order
-(define (n2u x) (list (& 0xFFFF (>> x 16)) (& 0xFFFF x)))
-
-# Compute 16 bit checksum of a small even number of bytes
-(define (checksum bytes)
- (apply + (n2u (- (apply + (map b2u (explode bytes 2)))))))
-
-# Pack a byte sequence into a string
-(define (pack-bytes bytes) (pack (dup "b" (length bytes)) bytes))
-
-# Join IP address bytes into a dotted quad string.
-(define (pack-ip x) (join (map string x) "."))
-
-# Process an IPv4 header byte sequence without checksum by inserting one.
-(define (ipv4-header-checksum h)
- (flat (list (0 10 h) (stonb (checksum h)) (10 h))))
-
-# Process an ICMP header byte sequence without checksum by inserting one.
-(define (icmp-header-checksum t c tail)
- (let ((data (unpack (dup "b" (length tail)) tail)))
- (flat (list t c (stonb (checksum (flat (list t c data)))) data))))
-
-# ARP request handler. Confirms the targeted IP address is one to
-# handle and then issues a corresponding reply. Note: the MAC address
-# is formed from the IP address.
-(define (arp-request-handler) ; buffer
- (letn ((IP (unpack "bbbb" (38 buffer))) (MYMAC (flat (list 2 IP 2))))
- (when (member IP MYIPS)
- (println "ARP request for " IP)
- (write IFD (pack "bbbbbb bbbbbb u u u b b u bbbbbb bbbb bbbbbb bbbb"
- (flat (list (unpack "bbbbbb" (6 buffer))
- MYMAC (map htons '(0x0806 0x1 0x0800 ))
- 0x06 0x04 (htons 0x2) MYMAC IP
- (unpack "bbbbbb bbbb" (22 buffer))
- ))
- )))))
-
-# ARP packet handler. Recognizes the ARP command involved, and for
-# some of them, it dispatches to the associated handler, if any.
-(define (arp-handler) ; buffer
- (case (ntohs ((unpack "u" (20 buffer)) 0)) ; ARP command
- (0x0001 (and arp-request-handler (arp-request-handler)))
- (true nil) ; ignore
- ))
-
-# ICMP request handler. Confirms that the targeted IP is one to
-# handle, and then issues a corresponding response.
-(define (icmp-request-handler)
- (letn ((h (unpack "bbbb bbbb" (26 buffer)))
- (n (ntohs((unpack "u" (16 buffer)) 0))))
- (println "ICMP request " (pack-ip (0 4 h)) " --> " (pack-ip (4 4 h)))
- (when (member (4 4 h) MYIPS)
- (write IFD
- (pack-bytes
- (flat (list
- # Ethernet header (14 bytes)
- (unpack "bbbbbb" (6 buffer))
- 2 (4 4 h) 2
- (stonb 0x0800) ; Type = IPv4
- # IPv4 header (20 bytes, with header checksum)
- (ipv4-header-checksum
- (flat (list 0x45 0 0 n
- (unpack "bbbbbb" (18 buffer))
- (4 4 h) (0 4 h))))
- # ICMP header
- (icmp-header-checksum 0 0 ((+ ihl 18) buffer))
- ))
- ))
- )))
-
-# ICMP packet handler. Recognizes the ICMP type involved and for some
-# of them, it dispatches to the associated handler, if any.
-(define (icmp-handler)
- (case ((unpack "b" ((+ ihl 14) buffer)) 0)
- (8 (and icmp-request-handler (icmp-request-handler)))
- (true)))
-
-# IPv4 packet handler. Recognises the IPv4 protocol involved, and for
-# some of them, it dispatches to the associated handler, if any.
-(define (ipv4-handler) ; buffer
- (let ((ihl (* (& 0x0F ((unpack "b" (14 buffer)) 0)) 4)))
- (case ((unpack "b" (23 buffer)) 0) ; protocol
- (0x01 (and icmp-handler (icmp-handler)))
- (0x02 (and igmp-handler (igmp-handler)))
- (0x04 (and ipip-handler (ipip-handler)))
- (0x06 (and tcp-handler (tcp-handler)))
- (0x11 (and udp-handler (udp-handler)))
- (true nil) ; ignore
- )
- ))
-
-# Ethernet packet handler. Recognises EtherTYpe involved, and for some
-# of them, it dispatches to the associated handler, if any.
-(define (handle-packet) ; buffer
- (when (> n 14)
- (case (ntohs ((unpack "u" (12 buffer)) 0)) ; Ethertype
- (0x0806 (and arp-handler (arp-handler)))
- (0x0800 (and ipv4-handler (ipv4-handler)))
- (0x86DD (and ipv6-handler (ipv6-handler)))
- (true nil) ; ignore all else
- )))
-
-# Tap handler. Reads an Ethernet packet from the tap, and invokes the
-# associated handler.
-(define (handle-tap)
- (let ((buffer "") (n nil))
- (if (setf n (read IFD buffer 8000)) (handle-packet)
- (die (string "** error reading " IFNAME)))))
-
-# Input handler. Waits for input on the tap or stdin, and invokes the
-# associated handler. This is set up as a prompt-event handler, so as
-# to multiplex tap handling with newlisp interactive command handling.
-(define (ioselect s)
- (letn ((fds (list 0 IFD)) (fdx nil))
- (until (member 0 (setf fdx (or (net-select fds "r" 10000000) '())))
- (when fdx (handle-tap))))
- nil)
-
-# "Main program" starts here
-(println "IP addresses on " IFNAME ":")
-(map println (map pack-ip MYIPS))
-(prompt-event ioselect)
+++ /dev/null
-taplet
-======
-
-This is a program to simulate ARP and ICMP responding hosts under a tap.
-
- Usage: taplet -t <tap> -ip <ip-list>
-
-where \<ip-list\> is a comma-separated list of the IP addresses (dotted quads)
-that the program should simulate. The program "binds" to the tap, and responds
-to ARP requests and ICMP requests.
-
-The program is a `newlisp` script, and it also lets you operate the `newlisp`
-command line, mutiplexed with handling network.
projects / rrq / newlisp-ftw.git / commitdiff