--- /dev/null
+# Apply timing control to this host
+# This is run as a cron job to either "close" or "open" the blocking of
+# the host via a configured control implementation.
+
+# File control.dat defines the limits, and control mechanism.
+# File activity-$date.dat is the local activity.
+
+(define (die)
+ (write-line 2 (join (map string args)))
+ (exit 1))
+
+(constant 'NOW (date-value))
+
+# Set current time variables in local timezone
+(map set '(YEAR MONTH DATE HOUR MINUTE SECOND DOY DOW)
+ (date-list (+ NOW (* 60 (now 0 -2)))))
+;(println (list YEAR MONTH DATE HOUR MINUTE SECOND DOY DOW))
+
+# Load "control.dat"
+# ( (control "file") (gap minutes) ( weekday start limit stop ) ... )
+(setf CONTROL (read-expr (read-file "control.dat")))
+(map set '(dow MODE START LIMIT END)
+ (or (assoc DOW CONTROL) (list DOW (6 30) 120 (20 0))))
+(setf
+ DAY (list YEAR MONTH DATE)
+ HM (list HOUR MINUTE)
+ TOTAL '()
+ GAP (or (lookup 'gap CONTROL) 15)
+ CLIP (or (lookup 'clip CONTROL) 1000)
+ )
+
+# Load control mechanism
+(if (lookup 'control CONTROL) (load $it)
+ (die "** Unknown control mechanism. Exiting!!"))
+(unless control
+ (die "** Unknown control action. Exiting!!"))
+
+(define (do-control x r) (control x r) (exit 0))
+
+(when (file? "control-extra.dat")
+ (let ((f (file-info "control-extra.dat" 6))
+ (x (regex "([0-9]+) ([0-9]+)" (read-file "control-extra.dat") 0)))
+ (when (and f x (<= NOW (+ f (* 3600 (int $1 0 10)) (* 60 (int $2 0 10)))))
+ (setf OVERRIDE true))))
+
+# Activity is lines of timestamps. Collect TOTAL as list of unique
+# time values (H M) within the start-end time span.
+
+(define (log-name-fmt t)
+ (format "%d%02d%02d-.*\\.dat" (0 3 (date-list t))))
+
+(define (log-lines f)
+ (find-all "([0-9]+( \\S+)?).*" (read-file (string "activity/" f)) $1 0))
+
+# Collect all timestamps of the UTC date of the given time stamp
+(define (logs t)
+ (flat (map log-lines (directory "activity" (log-name-fmt t)))))
+
+# Translate timestamp into its local time (hour minute), if it's
+# within the applicable open time, null otherwise.
+(define (period-minute x)
+ (when x
+ (letn ((d (date-list (+ (int x 0 10) (* 60 (now 0 -2)))))
+ (tm (3 2 d))
+ (on (if (regex "^[0-9]+ ([0-9]+)$" x 0) (> (int $1 0 10) CLIP) 1))
+ )
+ (and on (= (0 3 d) DAY) (>= tm START) (< tm END) tm))))
+
+# Collect all mentioned minutes from the activity logs
+(setf TOTAL
+ (unique
+ (clean null?
+ (map period-minute
+ (sort (extend (logs (- NOW 86400)) (logs NOW)))))))
+
+# Add all mentioned minutes, and fill in any time periods of less than
+# the configured GAP minutes between them.
+(define (minutes x) (+ (* (x 0) 60) (x 1)))
+(setf SUM 0)
+(when TOTAL
+ (setf LAST (minutes (pop TOTAL) SUM 1))
+ (dolist (x TOTAL)
+ (letn ((M (minutes x)) (V (- M LAST)))
+ (inc SUM (if (< V GAP) V 1))
+ (setf LAST M)))
+ )
+
+# Rework SUM into (h m) format
+(setf SUM (letn ((h (/ SUM 60)) (m (- SUM (* 60 h)))) (list h m)))
+
+(write-file ".usage.dat" (string SUM))
+(rename-file ".usage.dat" "usage.dat")
+
+# Close host outside start-end times
+(case MODE
+ (closed (do-control "close" "closed"))
+ (opened (do-control "open" "open"))
+ (timed
+ (when OVERRIDE (do-control "open" "override"))
+ (when (< HM START) (do-control "close" "early"))
+ (when (>= HM END) (do-control "close" "late"))
+ (when (> SUM LIMIT) (do-control "close" "usage"))
+ (do-control "open" "usage")
+ )
+ (true (die "Unknown control mode " MODE))
+ )
--- /dev/null
+#!/bin/bash
+
+cd $(dirname $0)
+/usr/local/bin/newlisp control-logic.lsp >> /tmp/hourglass-control.log 2>&1
--- /dev/null
+
+# Should load from "ipset.cfg"
+(constant 'TABLE "TIMO" 'NET "192.168.104.0/24"
+ 'IPSET "/sbin/ipset" )
+
+# Apply "add" or "del" on the controllable as needed, and exit
+(define (control cmd reason)
+ (let ((a (case cmd ("open" "del") ("close" "add") (true "XXX"))))
+ (when (!= cmd (if (exec (format "%s list %s | grep %s" IPSET TABLE NET))
+ "close" "open"))
+ (! (println (date-value) (format " ipset-control (%s): " reason)
+ (format "%s %s %s %s" IPSET a TABLE NET)))))
+ (exit 0))
+
+"ipset-control.lsp"
--- /dev/null
+#!/usr/local/bin/newlisp
+#
+
+# This program attaches to a tap interface for the purpose of noticing
+# activity via network traffic. The program serves as a virtual host
+# that receives duplicated packets, and analyses them to select those
+# that indicate activity.
+# Optional arguments:
+# -t tap = use the given tap rather than "tap0".
+
+(signal 2 (fn (x) (exit 0)))
+
+# The following is for Devuan GNU+Linux
+(constant 'LIBC (exists file? '("/lib/x86_64-linux-gnu/libc.so.6"
+ "/lib/i386-linux-gnu/libc.so.6"
+ )))
+(import LIBC "ioctl" "int" "int" "long" "void*" )
+(import LIBC "perror" "void" "char*" )
+(import LIBC "ntohl" "int" "int" )
+(import LIBC "ntohs" "int" "int" )
+(import LIBC "htons" "int" "int" )
+(import LIBC "htonl" "int" "int" )
+
+# Report low level system error and exit
+(define (die s) (perror s) (exit 1))
+
+# Utility function to 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))))
+
+# Set logging mode.
+(constant 'listener-log-ip (mainarg "-l" nil))
+
+# Open the tap named by "-t tapX" on the command line, or "tap0" byt
+# default. Then make a TUNSETIFF call to initialize it (as
+# IFF_TAP|IFF_NO_PI).
+(constant 'IFNAME (mainarg "-t" "tap0") '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)))
+
+# The TCP ports of interest
+(constant 'PORTS '(80 443))
+
+# Set up for optional tracking of IP addresses
+(define counter:counter nil)
+
+# This function accumulates packet size per ip+port, for monitored the
+# ports. This accumulates traffic in both directions.
+(define (track-data) ; buffer
+ (write-line 2 "track-data")
+ (let ((ips (explode (unpack "bbbb bbbb" ((+ 12 14) buffer)) 4)))
+ (dotimes (i 2)
+ (when (member (ports i) PORTS)
+ (let ((k (string (join (map string (ips i)) ".") "." (ports i))))
+ (counter x (+ (length buffer) (or (counter x) 0))))))))
+
+(define (track-data-reset)
+ (map delete (symbols counter)))
+
+(track-data-reset)
+
+# Mark the minute of t as an active minute. More exactly, it issues a
+# mark if it now is more than 60 seconds from the last issued mark.
+# This funcion collates all given ips, and it extends the log line
+# with the list of ips used during the minute.
+(setf next-mark 0 packet-count 0)
+(define (mark-active t) ; buffer
+ (when listener-log-ip (track-data))
+ (inc packet-count)
+ ;(write-line 2 (string (list t packet-count ports (counter))))
+ (when (>= t next-mark)
+ (let ((d (format "activity/%d%02d%02d-network.dat" (0 3 (date-list t))))
+ (c (map string (counter))))
+ (append-file d (string t " " packet-count " " (join c " ") "\n"))
+ (setf next-mark (+ t 60) packet-count 0)
+ (when listener-log-ip (track-data-reset))
+ )))
+
+# Handle an ARP request. This picks up IP address from the request.
+# The MAC address is formed from the IP address with 2 before and 2
+# after.
+(define (arp-request-handler) ; buffer
+ (letn ((MYIP (unpack "bbbb" (38 buffer))) (MYMAC (flat (list 2 MYIP 2))))
+ (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 MYIP
+ (unpack "bbbbbb bbbb" (22 buffer))
+ ))
+ ))))
+
+# Handle an ARP packet. It recognizes the ARP command involved, and
+# 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
+ ))
+
+# Handle a TCP packet. It reviews the ports involved, and if any is
+# among the interesting ports, then it marks activity together with ip
+# and port of sender and receiver.
+(define (tcp-handler) ; buffer ihl
+ (let ((ports (map ntohs (unpack "uu" ((+ ihl 14) buffer)))))
+ (when (intersect ports PORTS) (mark-active (date-value)))))
+
+(define (udp-handler) ; buffer ihl
+ (let ((ports (map ntohs (unpack "uu" ((+ ihl 14) buffer)))))
+ (when (intersect ports PORTS) (mark-active (date-value)))))
+
+# Handle an IPv4 packet. It recognises the IPv4 protocol concerned,
+# and 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
+ )
+ ))
+
+# This function handles an Ethernet packet by recognising the packet
+# type, and dispatch 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
+ )))
+
+# Read and handle a packet from the tap. The program handles ARP
+# requests by emitting an appropriate ARP response, and it handles TCP
+# packets to certain ports, which are seen as indications of activity.
+(define (handle-tap)
+ (let ((buffer "")(n nil))
+ (if (setf n (read IFD buffer 8000)) (handle-packet)
+ (begin (write-line 2 (format "IFD error")) (exit 1)))))
+
+# This function gets invoked prior to the interactive prompt. It'll
+# listen for data on the tap, and handle that, and also wake up every
+# second, so as to allow a timer effect to be set up.
+(define (ioselect s)
+ (letn ((fds (list IFD)) (fdx nil))
+ (until (member 0 (setf fdx (or (net-select fds "r" 10000000) '())))
+ (when fdx (handle-tap))))
+ nil)
+
+(prompt-event ioselect)
+(close 0)
+(while true (ioselect))
--- /dev/null
+cmFscGg6aGVsbG8=
+bGluOmhlbGxv
--- /dev/null
+#!/bin/bash
+#
+# Ensure there is an HTTP_AUTHORIZATION environment variable
+# with appropriate content
+
+# root user:password
+login_check() {
+ D=$(pwd)
+ while [ ! -f $D/.htpasswd ] ; do
+ [ "$D" = "$1" ] && return 0
+ if [ "$D" = / ] ; then
+ logger BAD FAILURE
+ return 1
+ fi
+ D=$(dirname $D)
+ done
+ if [ -z "$2" ] || ! grep -q "$2" $D/.htpasswd ; then
+ cat <<EOF
+Status: 401 Unauthorized
+WWW-Authenticate: Basic realm="Hourglass"
+EOF
+ return 1
+ fi
+}
+#logger "HTTP_AUTHORIZATION=$HTTP_AUTHORIZATION"
+if login_check "$(dirname $(dirname $0))" "${HTTP_AUTHORIZATION#Basic }" ; then
+
+ cd ..
+ REMOTE_USER="$(echo -n "${HTTP_AUTHORIZATION#Basic }" | base64 -d)"
+ REMOTE_USER="${REMOTE_USER%%:*}"
+ export REMOTE_USER
+ ROLE="$(grep "^${REMOTE_USER}": roles.txt)"
+ export ROLE="${ROLE#*:}"
+ if [ -f "$ROLE/$1" ] ; then
+ echo
+ exec /usr/local/bin/newlisp newlisp $ROLE/$1
+ fi
+fi
+cat <<EOF
+
+Broken.
+EOF
--- /dev/null
+; Index page for "child" role
+(load "expand-string.lsp")
+(println (expand-file "tmpl/index-page.html"))
+(exit 0)
--- /dev/null
+(define (time-parse x)
+ (if (nil? x) (throw nil)
+ (regex "([0-9][0-9])%3A([0-9][0-9])" x 0)
+ (list (int $1 0 10) (int $2 0 10))
+ (throw nil)
+ ))
+
+(define (int-parse x)
+ (if (nil? x) (throw nil)
+ (regex "^([0-9]+)$" x 0) (int $1 0 10) (throw nil)))
+
+(define (mode-parse x)
+ (if (member x '("closed" "timed" "opened")) (sym x) (throw nil)))
+
+(setf UPDATE "** UPDATE ERROR **")
+(catch
+ (let ((data "")(b "") (c '()) (v nil))
+ (while (read 0 b 1000) (extend data b))
+ (setf v (map (fn (x) (parse x "=")) (parse data "&")))
+ (push (list 'control "ipset-control.lsp") c -1)
+ (push (list 'gap (int-parse (lookup "gap" v))) c -1)
+ (push (list 'clip (int-parse (lookup "clip" v))) c -1)
+ (for (i 1 7)
+ (push (list i
+ (mode-parse (lookup (string "mode" i) v))
+ (time-parse (lookup (string "start" i) v))
+ (time-parse (lookup (string "limit" i) v))
+ (time-parse (lookup (string "end" i) v))
+ ) c -1))
+ (write-file "../control.dat"
+ (append (format "; Updated at %s\n(" (date))
+ (join (map string c) "\n " true)
+ ")\n"))
+ (setf UPDATE "* controls updated *")
+ ))
+
+"controls-update.lsp"
--- /dev/null
+; Load and present ../controls.dat
+
+(load "expand-string.lsp")
+
+(setf UPDATE "")
+
+(when (= (env "REQUEST_METHOD") "POST")
+ (load "controls-update.lsp")
+ )
+
+(constant
+ 'CONTROLFILE "../control.dat"
+ 'CONTROL (read-expr (read-file CONTROLFILE))
+ 'GAP (or (lookup 'gap CONTROL) 5)
+ 'CLIP (or (lookup 'clip CONTROL) 5)
+ 'INCL (or (lookup control CONTROL) "ipset-control.lsp")
+ 'TIMES (map (fn (n) (or (assoc n CONTROL) '(1 timed (7 0) (3 0) (19 0))))
+ (sequence 1 7))
+ )
+
+(setf
+ DAYS '(0 "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
+ incl-options '("ipset-control.lsp")
+ gap-options '(0 1 2 5 10 15 30)
+ clip-options '(0 200 500 800 1000 1200 1500 2000)
+ mode-options '("opened" "timed" "closed")
+ start-options '()
+ end-options '()
+ limit-options '()
+ )
+(dotimes (h 23) (dolist (m '(0 30))
+ (push (format "%02d:%02d" h m) start-options -1)))
+(dotimes (h 23) (dolist (m '(0 30))
+ (push (format "%02d:%02d" h m) end-options -1)))
+(for (h 1 8) (dolist (m '(0 30))
+ (push (format "%02d:%02d" h m) limit-options -1)))
+
+(println (expand-file "tmpl/controls-form.html" ))
+(exit 0)
--- /dev/null
+;; @module expand-string.lsp
+;; @author Ralph Ronnquist, Real Thing Entertainment Pty. Ltd.
+;; @location http://www.realthing.com.au/files/newlisp/expand-string.lsp
+;; @version 1.3, 2015-09-14 Added markdown blocks
+;; @version 1.2, 2015-08-22
+;; @description Inclusion module providing string templating using expansion.
+;
+;; This is an inclusion module that provides an <expand-string>
+;; function to process a string template and replace key tokens as
+;; declared in a rules list of token-to-replacement associations with
+;; their associated values. It offers a similar function to <expand>,
+;; but for strings, and using string pattern match without
+;; tokenization to determine the replacement points. Further, it
+;; evaluates the rule value parts to make the replacements.
+;;
+;; The <expand-string> module was developed as a means to separate
+;; logic and rendering in newlisp CGI scripting, and thereby
+;; facilitate a higher degree of modularisation, in the aim of
+;; increasing the maintainability. It supports the design principle
+;; where the handling of a request is directed to a newlisp "logic
+;; script" that implements the request logic, and finishes by response
+;; rendering via an <expand-file> call.
+;;
+;; By virtue of the replacement value evaluation, the response
+;; rendering is more than a substitution of keywords. Rather it
+;; selectively transitions back into newlisp evaluation, e.g., to pick
+;; up particulars from the logic context, and transform and combine
+;; them for rendering purposes.
+;;
+;; This makes it easy to achieve a consistent appearance across all
+;; response pages, by sharing inclusion fragments. For example,
+;; response templates may include a common ingress fragment, common
+;; component fragments, and a common egress fragment. Such fragments
+;; may be included generically by using <?newlisp ?> or
+;; <EVAL>..</EVAL> phrases to invoke <expand-file> for the
+;; inclusion fragments, or it may be done specifically by special
+;; replacement rules.
+;
+;; <hr/>
+;
+;; @syntax (expand-string <text> <rules>)
+;; The <expand-string> function processes the given text for the
+;; occurrences of the rule keys, and replaces these with the values
+;; obtained by evaluating the associated value expressions. The result
+;; is the new string with replacements. Note that a value expression
+;; may affect variable <txt>, which is the rest of the input following
+;; the expanding key, to optionally consume additional text in the
+;; replacement. See function <.expand-map> for an example.
+;
+;; @syntax (expand-file file rules)
+;; The <expand-file> function reads the file and expand it using
+;; <expand-string> with the rules.
+;
+;; @syntax (.expand-eval <ctx> <end>)
+;; This function is intended as expansion value function for an
+;; <expand-string> rule, to implement template expression
+;; evaluation. The <ctx> parameter tells the context for symbol
+;; creations. The optional <end> parameter tells the end of the
+;; replacement fragment. This function extracts the text fragment
+;; until the nearest <end> text, then evaluates this with
+;; <eval-string>, makes the result a string, and uses that as value to
+;; replace the whole block. See <default-expand-rules> below how a
+;; rule using this function may look.
+;
+;; @syntax (.expand-cond <ctx> <mid> <end>)
+;;
+;; This function is intended as an expansion value function for an
+;; <expand-string> rule, to implement template fragment conditional
+;; cascade. The optional <mid> parameter tells the pattern that
+;; divides the cascaded parts, which is "<ELSEIF/>" by default,
+;; and the optional <end> parameter tells the end of the whole cascade
+;; fragment, which is "</IF>" by default. Note that the <mid>
+;; pattern is a divider between the conditional parts. and thereby
+;; both the end of the preceding part, and the beginning of the
+;; succeeding part.
+;;
+;; The cascaded parts are processed in order, for selecting one to
+;; include and expand recursively. To this end, each part starts with
+;; an s-expression, that gets evaluated to determine whether the part
+;; should be included or not. If the value is nil, the the part is
+;; ignored, and the processing continues with the next part. If the
+;; value is non-nil, the rest of the part is expanded recursively via
+;; <expand-string>, and this is then returned as the expansion result
+;; of the cascade. If none of the parts is selected, the cascade
+;; expansion results in the empty string.
+;
+;; @syntax (.expand-map <ctx> <end>)
+;; This function is intended as expansion value function for an
+;; <expand-string> rule, to implement template fragment
+;; repetition. The optional <ctx> parameter tells the context for
+;; symbol creations. The optional <end> parameter tells the end of the
+;; fragment portion, which is "</MAP>" by default. The function
+;; pulls two s-expression from the template using <read-expr>. The
+;; first is a list of keys, and the second a list of binding lists for
+;; those keys. The rest of the fragment is then expanded recursively,
+;; repeatedly, with the keys having their subsequent bindings, and the
+;; block is replaced by the concatenation of these results. See
+;; <default-expand-rules> below how a rule using this function may
+;; look.
+;
+;; @syntax (.expand-markdown <ctx> <end>)
+;
+;; This function is intended as expansion value function for an
+;; <expand-string> rule, to implement template fragment markdown
+;; processing. It first passes the fragment for recursive
+;; expand-string processing, the uses the
+;; @link http://daringfireball.net/projects/markdown markdown
+;; program to translate the fragment into html.
+;
+;; @syntax (mapv <name>)
+;; This is a utility macro to both lookup a name in the current rules,
+;; and bind its value as the value for that variable. This is
+;; typically used for referring to a <MAP> variable.
+;
+;; @syntax default-expand-rules
+;; This constant holds a few default rules for using repetition end
+;; expression evaluation. Currently set to the following:
+;; <pre>
+;; (constant 'default-expand-rules
+;; '(("<MAP1>" (.expand-map MAIN "</MAP1>"))
+;; ("<MAP2>" (.expand-map MAIN "</MAP2>"))
+;; ("<MAP3>" (.expand-map MAIN "</MAP3>"))
+;; ("<MAP>" (.expand-map MAIN "</MAP>"))
+;; ("<EVAL>" (.expand-eval MAIN "</EVAL>"))))
+;; ("<?newlisp" (.expand-eval MAIN "?>"))
+;; ("<markdown>" (.expand-eval MAIN "</markdown>"))
+;; ))
+;; </pre> These default rules obviously favours HTML templates.
+;;
+;; <center>§</center>
+;; <h2>Examples</h2>
+;; <b>Example:</b> The following is an illustration of <expand-string>
+;; using <.expand-map>:
+;; <pre>(expand-string
+;; "<MAP>(A B) '((1 2) (3 4)) A B B A</MAP>"
+;; '(("<MAP>" (.expand-map)) ))
+;; </pre>
+;; The example results in the string " 1 2 2 1 3 4 4 3".
+;;
+;; Note that the binding lists expression is evaluated in the given
+;; context, or MAIN, if nil is given. Thus, the rule above is
+;; equivalent with the following: <tt>(.expand-map MAIN "</MAP>")</tt>
+;;
+;; Note also that the fragment blocks cannot be nested. To achieve
+;; nested repetition, use several tag pairs, as in the following rule set:
+;; <pre> '(("<MAP1>" (.expand-map nil "</MAP1>"))
+;; ("<MAP2>" (.expand-map nil "</MAP2>"))
+;; ("<MAP3>" (.expand-map nil "</MAP3>")) )</pre>
+;; In that case, the outer expansion keys may be used in the inner
+;; repetition although they are not actually bound to the values.
+;;
+;; <b>Example:</b>
+;; <pre>(expand-string
+;; {<EVAL>(first (exec "uname -mrs"))</EVAL>}
+;; default-expand-rules )</pre>
+;; This example results in the machine details as reported by the
+;; <uname> program with the <-mrs> command line argument.
+;;
+;; <b>Example:</b> This example illustrates HTML rendering, with a
+;; template file that includes certain keys for expansion. In this
+;; case I have a list if paragraps as value of variable <texts>, and
+;; want them inserted nicely into an HTML page. Note that the spaces
+;; following the two s-expressions in the <MAP>..</MAP>
+;; construct are compulsory, and they get consumed by the <read-expr>
+;; function.
+;
+;; <pre> @PAGEDOCTYPE@
+;; <html><head><title>@TITLE@</title></head>
+;; <body><h1>@TITLE@</h1>
+;; <MAP>(text) texts <p>text</p></MAP>
+;; </body></html></pre>
+;
+;; This template would be used in a context that provides suitable
+;; expansion rules for the "@PAGEDOCTYPE@" and "@TITLE@" keys, as well
+;; as the default "<MAP>" expansion rule.
+;;
+;; <b>Example:</b> This example illustrates the use of a conditional
+;; cascade template fragment. It expands to one of the sentences
+;; depending on the conditions.
+;;
+;; <pre> <IF> (> (setf cnt (length (index fresh strawberries))) 10)
+;; Mostly fresh strawberries.
+;; <ELSEIF/> (> cnt 5) Many strawberries are fresh.
+;; <ELSEIF/> (> cnt) At least some strawberries are fresh.
+;; <ELSEIF/> true None of the strawberries are fresh.
+;; </IF></pre>
+;
+;; Thus in the example, if the list <strawberries> has more than 10
+;; elements qualified as <fresh>, then the expansion is "Mostly fresh
+;; strawberries.". As a side effect, the count is cached by the first
+;; evaluation, regardless of the value, and this is then used in the
+;; subsequent expressions.
+;;
+;; <b>Example:</b> This example illustrates the use of a markdown,
+;; where the template is somewhat more readable.
+;; <pre>
+;; <markdown>
+;; # This is a H1 header<br>
+;; A first paragraph.<br>
+;; ## Then a H2 header<br>
+;; And a second paragraph with [this link](http://www.realthing.com.au) to somewhere.<br>
+;; * A list item
+;; * and another list item
+;; 1. with a numbered sub item in the item
+;; 1. and a second sub item<br>
+;; and so on...
+;; </markdown>
+;; </pre>
+;; Note that the markdown block is expanded recursively before being
+;; passed to the markdown processor. Thus, that inner expansion may
+;; result in markdown as well as raw HTML (which the markdown
+;; processor digests without ado).
+
+############################################################
+
+(define (rule-key rule)
+ (replace "[\\?*.()]" (first rule) (string "\\" $it) 0))
+
+(define (expand-string txt (rules default-expand-rules))
+ (if (null? rules) txt
+ (let ((pat (string "(" (join (map string (map rule-key rules)) "|") ")"))
+ (out "") (i 0))
+ (while (setf i (find pat txt 0))
+ (extend out (0 i txt))
+ (setf txt ((+ i (length $1)) txt))
+ (extend out (string (eval (lookup $1 rules)))))
+ (extend out txt))))
+
+(define (expand-file file (rules default-expand-rules))
+ ;(write-line 2 (string "expand-file " file " " rules))
+ (expand-string (read-file file) rules))
+
+(define (.expand-map ctx (end "</MAP>")) ; uses txt rules
+ (let ((A (map term (read-expr txt (or ctx MAIN) nil 0)))
+ (dlist (read-expr txt (or ctx MAIN) nil $count))
+ (frag ($count (- (find end txt nil $count) $count) txt))
+ (out ""))
+ (setf txt ((+ $count (length frag) (length end)) txt))
+ (dolist (d (eval dlist))
+ (extend out (expand-string frag (extend (map list A d) rules))))
+ out))
+
+(define (.expand-eval ctx (end "</EVAL>")) ; uses txt rules
+ (let ((frag (0 (find end txt nil 0) txt)))
+ (setf txt ((+ (length frag) (length end)) txt))
+ (string (eval-string frag))))
+
+(define (.expand-cond ctx (mid "<ELSEIF/>") (end "</IF>"))
+ (let ((frag (0 (find end txt nil 0) txt)) (fi 0) (ti 0) (ex nil) (out ""))
+ (setf txt ((+ (length frag) (length end)) txt))
+ (while (and (null? ex) (< fi (length frag)))
+ (setf ex (read-expr frag (or ctx MAIN) nil fi))
+ (setf fi $count)
+ (setf ti (or (find mid frag nil fi) (length frag)))
+ (if (setf ex (eval ex))
+ (setf out (fi (- ti fi) frag))
+ (setf fi (+ ti (length mid)))))
+ (expand-string out rules)))
+
+; Process a block for markdown after recursive expansion
+(define (.expand-markdown ctx end) ; uses <txt>
+ (let ((frag (0 (find end txt nil 0) txt)))
+ (setf txt ((+ (length frag) (length end)) txt))
+ (letn (f (string "/tmp/markdown-" (date-value)))
+ (when (exec (format "/usr/bin/markdown --html4tags > %s" f)
+ (expand-string frag rules))
+ (read-file f)))))
+
+(constant 'default-expand-rules
+ '(("<MAP1>" (.expand-map MAIN "</MAP1>"))
+ ("<MAP2>" (.expand-map MAIN "</MAP2>"))
+ ("<MAP3>" (.expand-map MAIN "</MAP3>"))
+ ("<MAP>" (.expand-map MAIN "</MAP>"))
+ ("<EVAL>" (.expand-eval MAIN "</EVAL>"))
+ ("<IF>" (.expand-cond MAIN "<ELSEIF/>" "</IF>"))
+ ("<?newlisp" (.expand-eval MAIN "?>"))
+ ("<markdown>" (.expand-markdown MAIN "</markdown>"))
+ ))
+
+(define-macro (mapv name) (set name (lookup (string name) rules)))
+
+(global 'expand-string 'expand-file '.expand-map 'default-expand-rules 'mapv)
+
+"expand-string.lsp"
+
--- /dev/null
+(load "expand-string.lsp")
+
+# Make a plot file with 0-24 vertically, days horizontally
+# Relative now...
+
+(setf
+ NOW (now)
+ TZ (NOW -2)
+ TZTODAY (- (date-value (0 3 NOW)) (* TZ 60))
+ DAYSEC (* 24 3600)
+ )
+
+(define (plotpoint x)
+ (when x
+ (letn ((n (div (- x TZTODAY) DAYSEC))
+ (d (if (< n) (- (int n) 1) (int n)))
+ (s (mul 24 (if (< n) (sub n d) (sub n d)))))
+ (list d s))
+ ))
+
+(define (usage x)
+ (and (regex "([0-9]+) ([0-9]+)" x 0)
+ (> (int $2 0 10) 1000)
+ (plotpoint (int $1 0 10))))
+
+(define (usage-file dat)
+ (clean null?
+ (map usage
+ (parse (read-file (format "../activity/%s" dat)) "\n"))))
+
+(setf
+ USAGE (sort (flat (map usage-file (directory "../activity" "^[^.]")) 1) <)
+ MAP '()
+ )
+
+(dolist (u USAGE)
+ (unless (assoc (u 0) MAP) (push (list (u 0)) MAP))
+ (push (u 1) (assoc (u 0) MAP) -1))
+
+(define (mkmap x)
+ (let ((s (dup "." (* 24 4))))
+ (dolist (e x) (setf (s (int (mul e 4))) "X"))
+ s))
+
+(setf MAP (map (fn (x) (list (x 0) (mkmap (1 x)))) MAP))
+
+(println (expand-file "tmpl/history-page.html"))
+(exit 0)
+(load
+
\ No newline at end of file
--- /dev/null
+(load "expand-string.lsp")
+(println (expand-file "tmpl/index-page.html"))
+(exit 0)
--- /dev/null
+ralph:.
+lin:.
--- /dev/null
+<html><head><title>Hourglass Controls</title>
+ <link rel="stylesheet" href="/hourglass.css">
+ </head>
+ <body>
+ <center>
+ <h1>Control Settings</h1>
+ <form method="POST" action="controls.cgi">
+ <table>
+ <tr>
+ <th>Weekday</th>
+ <th>Toggle</th>
+ <th>Start</th>
+ <th>Limit</th>
+ <th>End</th>
+ </tr>
+ <MAP> (@DN @MODE @START @LIMIT @END) TIMES
+ <tr>
+ <th><?newlisp (DAYS (mapv @DN))?></th>
+ <td>
+ <select name="mode@DN">
+ <MAP1> (@X) (map list mode-options) <option value="@X"
+<?newlisp
+ (if (= (string (mapv @MODE)) (mapv @X)) "selected" "")
+?>> @X</option>
+ </MAP1>
+ </select>
+ </td>
+ <td>
+ <select name="start@DN">
+ <MAP1> (@X) (map list start-options) <option value="@X"
+<?newlisp
+ (if (= (format "%02d:%02d" (mapv @START)) (mapv @X)) "selected" "")
+?>> @X</option>
+ </MAP1>
+ </select>
+ </td>
+ <td>
+ <select name="limit@DN">
+ <MAP1> (@X) (map list limit-options) <option value="@X"
+<?newlisp
+ (if (= (format "%02d:%02d" (mapv @LIMIT)) (mapv @X)) "selected" "")
+?>> @X</option>
+ </MAP1>
+ </select>
+ </td>
+ <td>
+ <select name="end@DN">
+ <MAP1> (@X) (map list end-options) <option value="@X"
+<?newlisp
+ (if (= (format "%02d:%02d" (mapv @END)) (mapv @X)) "selected" "")
+?>> @X</option>
+ </MAP1>
+ </select>
+ </td>
+ </tr>
+ </MAP>
+ </table>
+ <div id="extras">
+ <div id="gap_toggle" class="extra">
+ <select name="gap">
+ <MAP> (X) (map list gap-options) <option value="X"
+<?newlisp (if (= (mapv X) GAP) "selected" "")?>>X</option></MAP>
+ </select>
+ idle minutes between activity sessions.
+ </div>
+ <div id="clip-toggle">
+ <select name="clip" class="extra">
+ <MAP> (X) (map list clip-options) <option value="X"
+<?newlisp (if (= (mapv X) CLIP) "selected" "")?>>X</option></MAP>
+ </select>
+ networks packets in a minute, to count as activity.
+ </div>
+ </div>
+ <div id="form_submit" class="extra" >
+ <?newlisp UPDATE?>
+ <input type="submit" value="update">
+ </div>
+ </form>
+ </center>
+ </body>
+</html>
--- /dev/null
+<html><head><title>Hourglass Controls</title>
+ <link rel="stylesheet" href="/hourglass.css">
+ </head>
+ <body>
+<table>
+<tr><td></td><td><pre>|---v---v---v---4am-v---v---v---8am-v---v---v---12--v---v---v---4pm-v---v---v---8pm-v---v---v---</pre></td></tr>
+<MAP> (@DAY @TIMES) MAP
+<tr><td>@DAY</td><td><pre>@TIMES</pre></dt></tr></div></MAP>
+</table>
+ </body>
+</html>
--- /dev/null
+<!DOCTYPE html>
+<html><head><title>Hourglass</title>
+ <link rel="stylesheet" href="/hourglass.css">
+ </head>
+ <body>
+ <div id="header">
+ <div class="title"> Hourglass Manager</div>
+ </div>
+ <iframe id="usage" src="/usage.cgi"></iframe>
+ <iframe id="controls" src="/controls.cgi"></iframe>
+ </body>
+</html>
--- /dev/null
+ <form method="GET" action="usage.cgi">
+ <div id="extra_usage">
+ Allow another
+ <select name="extra" class="extra">
+ <MAP> (X) (map list extra-options)
+ <option value="X">X</option></MAP>
+ </select>
+ minutes of open time.
+ </div>
+ </form>
--- /dev/null
+<html><head><title>Hourglass Controls</title>
+ <meta http-equiv="refresh" content="60">
+ <link rel="stylesheet" href="/hourglass.css">
+ </head>
+ <body>
+ <h2>Today's usage: <?newlisp (format "%d:%02d" USAGE)?></h2>
+ <span id="extra_time"><?newlisp (format "%d:%02d" X)?> extra time.</span>
+ <form id="extra_usage_form" method="POST" action="/usage.cgi">
+ <input type="submit" value="set extra minutes">
+ <select name="minutes">
+ <option value="0">0</option>
+ <option value="5">5</option>
+ <option value="10">10</option>
+ <option value="15" selected>15</option>
+ <option value="20">20</option>
+ <option value="30">30</option>
+ <option value="45">45</option>
+ <option value="60">60</option>
+ </select>
+ </form>
+ <div>
+ <iframe id="history" src="/history.cgi"></iframe>
+ </div>
+ </body>
+</html>
--- /dev/null
+(define (set-usage-extra m)
+ (let ((h (/ m 60)))
+ (setf m (- m (* h 60)))
+ (write-file "../control-extra.dat" (format "%d %d\n" h m))))
+
+(catch
+ (let ((data "")(b "") (c '()) (v nil))
+ (while (read 0 b 1000) (extend data b))
+ (setf v (map (fn (x) (parse x "=")) (parse data "&")))
+ (set-usage-extra (int (or (lookup "minutes" v) "0") 0 10))))
+
+"usage-extra.lsp"
--- /dev/null
+(load "expand-string.lsp")
+
+(when (= (env "REQUEST_METHOD") "POST")
+ (load "usage-extra.lsp")
+ )
+
+(define (get-remote-user)
+ (and (regex "^([^:]+):" (base64-dec (6 (env "HTTP_AUTHORIZATION"))) 0) $1))
+
+(constant
+ 'ADMIN (member (get-remote-user) '("ralph" "lin"))
+ 'USAGE (read-expr (read-file "../usage.dat"))
+ 'extra-options '(0 10 30 60)
+ 'EXTRAFILE "../control-extra.dat"
+ 'EXTRATM (file-info EXTRAFILE 6)
+ 'TM (date-value)
+ 'EXTRA (and (regex "([0-9]+) ([0-9]+)" (or (read-file EXTRAFILE) "") 0)
+ (list (int $1 0 10) (int $2 0 10)))
+ )
+
+(define (tm2time tm)
+ (if (> tm)
+ (letn ((m (/ tm 60)) (h (/ m 60))) (list h (- m (* 60 h))))
+ '(0 0))
+ )
+
+(define (time2tm t)
+ (+ (* 3600 (t 0)) (* 60 (t 1))))
+
+(setf X '(0 0))
+(when (and EXTRATM EXTRA (>= TM EXTRATM))
+ (setf X (tm2time (- (+ EXTRATM (time2tm EXTRA)) TM))))
+
+(println (expand-file "tmpl/usage-form.html" ))
+(exit 0)
--- /dev/null
+#!/bin/bash
+
+. ../basic_login.sh controls.lsp
--- /dev/null
+#!/bin/bash
+
+. ../basic_login.sh history.lsp
--- /dev/null
+body {
+ text-align: center;
+}
+p {
+ margin-left: 300px;
+}
+
+#header {
+}
+.logo {
+}
+.logo img{
+ float: right;
+ height: 60px;
+ padding: 10px;
+}
+.title {
+ padding-top: 24px;
+ text-align: center;
+ font-size: 32pt;
+ font-weight: bold;
+}
+#usage {
+ margin-top: 10px;
+ width: 100%;
+ height: 200px;
+ border: none;
+ overflow: hidden;
+}
+#history {
+ width: 80%;
+ height: 120px;
+}
+#controls {
+ width: 60%;
+ height: 430px;
+// border: none;
+}
+#form_submit {
+ margin-top: 10px
+}
+#extras {
+ text-align: left;
+ display: inline-block;
+ margin-top: 10px;
+}
+#extra_usage_form {
+ display: inline;
+ margin-left: 10px;
+}
+#extra_time {
+ font-size: 12pt;
+}
+.extra {
+ margin-top: 6px;
+}
+table tr td {
+ padding-top: 6px;
+ padding-right: 6px;
+}
--- /dev/null
+#!/bin/bash
+
+. ../basic_login.sh index.lsp
--- /dev/null
+#!/bin/bash
+
+. ../basic_login.sh usage.lsp
--- /dev/null
+#!/bin/bash
+
+CMD=${1-start}
+NET=192.168.249
+TAP=tap0
+
+cd $(dirname $0)
+
+RULE=( ! -o $TAP -j TEE --gateway $NET.2 --oif $TAP )
+case "$CMD" in
+ start)
+ if ifconfig $TAP >& /dev/null ; then
+ echo "Already started"
+ else
+ date >> /tmp/hourglass-listener.log
+ newlisp listener.lsp >> /tmp/hourglass-listener.log 2>&1 &
+ while sleep 1 ; do
+ ifconfig $TAP >& /dev/null && break
+ echo $TAP not up yet
+ done
+ ifconfig $TAP $NET.1 up
+ iptables -t mangle -A FORWARD ${RULE[@]}
+ fi
+ ;;
+ stop)
+ iptables -t mangle -F FORWARD
+ if ifconfig $TAP >& /dev/null ; then
+ pkill -2 -f listener.lsp
+ else
+ echo "Already stopped"
+ fi
+ ;;
+ *)
+ echo "Unknown: $CMD"
+ ;;
+esac
projects / rrq / hourglass.git / commitdiff
