Reorder X-Arc-Secure arg

Reorder X-Arc-Secure arg

; HTTP Server.

; To improve performance with static files, set static-max-age*.

(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")

(^ quitsrv* nil breaksrv* nil)

(def serve ((o port 8080))
  (wipe quitsrv*)
  (ensure-srvdirs)
  (map [apply new-bgthread _] pending-bgthreads*)
  (w/socket s port
    (setuid 2) ; XXX switch from root to pg
    (prn "ready to serve port " port)
    (flushout)
    (= currsock* s)
    (until quitsrv*
      (handle-request s breaksrv*)))
  (prn "quit server"))

(def serve1 ((o port 8080))
  (w/socket s port (handle-request s t)))

(def ensure-srvdirs ()
  (map ensure-dir (list arcdir* logdir* staticdir*)))

(^ srv-noisy* nil)

; http requests currently capped at 2 meg by socket-accept

; should threads process requests one at a time? no, then
; a browser that's slow consuming the data could hang the
; whole server.

; wait for a connection from a browser and start a thread
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.

(^ threadlife* 30  requests* 0  requests/ip* (table)
   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))

(def handle-request (s breaksrv)
  (if breaksrv
      (handle-request-1 s)
      (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (let (i o ip) (socket-accept s)
    (if (and (or (ignore-ips* ip) (abusive-ip ip))
             (++ (spurned* ip 0)))
        (force-close i o)
        (do (++ requests*)
            (++ (requests/ip* ip 0))
            (with (th1 nil th2 nil)
              (= th1 (thread
                       (after (handle-request-thread i o ip)
                              (close i o)
                              (kill-thread th2))))
              (= th2 (thread
                       (sleep threadlife*)
                       (unless (dead th1)
                         (prn "srv thread took too long for " ip))
                       (break-thread th1)
                       (force-close i o))))))))

; Returns true if ip has made req-limit* requests in less than
; req-window* seconds.  If an ip is throttled, only 1 request is
; allowed per req-window* seconds.  If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).

; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.

(^ req-times* (table) req-limit* 30 req-window* 10 dos-window* 2 dos-protection* nil)

(def abusive-ip (ip)
  (and dos-protection*
       (only.> (requests/ip* ip) 250)
       (let now (seconds)
         (do1 (if (req-times* ip)
                  (and (>= (qlen (req-times* ip))
                           (if (throttle-ips* ip) 1 req-limit*))
                       (let dt (- now (deq (req-times* ip)))
                         (if (< dt dos-window*) (set (ignore-ips* ip)))
                         (< dt req-window*)))
                  (do (= (req-times* ip) (queue))
                      nil))
              (enq now (req-times* ip))))))

(def noisy-header (lines (o label) (o footer "\n"))
  (when srv-noisy*
    (atomic
      (if label (pr label))
      (each line lines
        (prn line))
      (if footer (pr footer))
      (flushout)))
  lines)

(def handle-request-thread (i o ip)
  (with (nls 0 lines nil line nil responded nil t0 (msec))
    (after
      (whilet c (unless responded (readc i))
        (if (is c #\newline)
            (if (is (++ nls) 2)
                (withs (h (noisy-header (rev lines) (+ "Time: " (moment-ms) "\nHeader: "))
                        (type op args n cooks ip . more) (parseheader h ip))
                  (let t1 (msec)
                    (case type
                      get  (respond o op args cooks ip)
                      post (handle-post i o op args n cooks ip)
                           (respond-err o "Unknown request: " (car lines)))
                    (log-request type op args cooks ip t0 t1)
                    (set responded)))
                (do (push (string (rev line)) lines)
                    (wipe line)))
            (unless (is c #\return)
              (push c line)
              (= nls 0))))
      (close i o)))
  (harvest-fnids))

(def log-request (type op args cooks ip t0 t1)
  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
    (srvlog 'srv ip
                 parsetime
                 respondtime
                 (if (> (+ parsetime respondtime) 1000) "***" "")
                 type
                 op
                 (let arg1 (car args)
                   (if (caris arg1 "fnid") "" arg1))
                 cooks)))

; Could ignore return chars (which come from textarea fields) here by
; (unless (is c #\return) (push c line))

(def handle-post (i o op args n cooks ip)
  (if (no n)
      (respond-err o "Post request without Content-Length.")
      (let line nil
        (whilet c (and (> n 0) (readc i))
          (-- n)
          (push c line))
        (let line (string (rev line))
          (noisy-header (list line) "Post Contents: ")
          (respond o op (+ (parseargs line) args) cooks ip)))))

(^ type-header* (table))

(def gen-type-header (ctype)
  (+ "HTTP/1.0 200 OK
Content-Type: "
     ctype
     "
Connection: close"))

(= header* (gen-type-header "text/html; charset=utf-8"))
(= secure-header* "X-Frame-Options: DENY
X-Content-Type-Options: nosniff
X-XSS-Protection: 1; mode=block
Strict-Transport-Security: max-age=31556900
";Content-Security-Policy: default-src 'self'; script-src 'self' 'unsafe-inline' https://www.google.com/recaptcha/ https://www.gstatic.com/recaptcha/ https://cdnjs.cloudflare.com/; frame-src 'self' https://www.google.com/recaptcha/; style-src 'self' 'unsafe-inline'"
)

(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
     '((image/x-icon "image/x-icon")
       (image/svg "image/svg+xml")
       (image/gif "image/gif")
       (image/jpg "image/jpeg")
       (image/png "image/png")
       (text/plain "text/plain")
       (text/html "text/html; charset=utf-8")
       (text/css  "text/css")
       (text/xml  "text/xml")
       (application/json        "application/json")
       (application/javascript  "application/javascript")
       (application/manifest    "application/manifest+json")
       ))

(= rdheader* "HTTP/1.0 302 Moved")

(^ srvops* (table) redirector* (table) optimes* (table) opcounts* (table))

(def save-optime (name elapsed)
  ; this is the place to put a/b testing
  ; toggle a flag and push elapsed into one of two lists
  (++ (opcounts* name 0))
  (unless (optimes* name) (= (optimes* name) (queue)))
  (enq-limit elapsed (optimes* name) 1000))

; For ops that want to add their own headers.  They must thus remember
; to prn a blank line before anything meant to be part of the page.

(mac defop-raw (name parms . body)
  (w/uniq t1
    `(= (srvops* ',name)
        (fn ,parms
          (let ,t1 (msec)
            (do1 (do ,@body)
                 (save-optime ',name (- (msec) ,t1))))))))

(mac defopr-raw (name parms . body)
  `(= (redirector* ',name) t
      (srvops* ',name)     (fn ,parms ,@body)))

(mac defop (name parm . body)
  (w/uniq gs
    `(do (wipe (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           (w/stdout ,gs (prn) ,@body)))))

; Defines op as a redirector.  Its retval is new location.

(mac defopr (name parm . body)
  (w/uniq gs
    `(do (set (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           ,@body))))

;(mac testop (name . args) `((srvops* ',name) ,@args))

(deftem request
  args  nil
  cooks nil
  ip    nil)

(= unknown-msg* "Unknown.")
(^ max-age* (table) static-header* (table) static-max-age* nil)

(def respond (str op args cooks ip)
  (or (hook 'respond str op args cooks ip)
      (w/stdout str
        (let (op args) (parseop op args)
          (iflet f (srvops* op)
                 (let req (inst 'request 'op op 'args args 'cooks cooks 'ip ip)
                   (if (redirector* op)
                       (do (prn rdheader*)
                           (aand (or (hook 'respond-headers str req f t)
                                     (f str req)
                                     "/")
                                 (prn "Location: " it))
                           (prn))
                       (do (prn (aif (static-header* op) (gen-type-header it) header*))
                           (awhen (max-age* op)
                             (prn "Cache-Control: max-age=" it))
                           (when (srvsecure req)
                             (prn secure-header*))
                           (or (hook 'respond-headers str req f nil)
                               (f str req)))))
                 (withs (op (car (tokens op #\?))
                         filetype (static-filetype op))
                   (aif (and filetype (file-exists (string staticdir* op)))
                        (do (prn (or (static-header* op) (type-header* filetype)))
                            (awhen static-max-age*
                              (prn "Cache-Control: max-age=" it))
                            (prn)
                            (w/infile i it
                              (whilet b (readb i)
                                (writeb b str))))
                        (respond-err str unknown-msg*))))))))

(def static-filetype (sym)
  (let fname (str sym)
    (and (~find #\/ fname)
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "ico"  'image/x-icon
           "svg"  'image/svg
           "gif"  'image/gif
           "jpg"  'image/jpg
           "jpeg" 'image/jpg
           "png"  'image/png
           "css"  'text/css
           "txt"  'text/plain
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/plain
           "xml"  'text/xml
           "js"           'application/javascript
           "json"         'application/json
           "webmanifest"  'application/manifest
           ))))

(def respond-err (str msg . args)
  (w/stdout str
    (prn header*)
    (prn)
    (apply pr msg args)))

(def parseop (op args)
  (let xs (tokens op #\/)
    (if (< (len xs) 2)
        (list op args)
        (list (sym (car xs)) (join (list (list "path" (concat (cdr xs) #\/))) args)))))

(^ the-header* (make-param nil)
   the-req* (make-param nil))

(def srvsecure ((o req (the-req*)))
  (is (arg req "X-Arc-Secure") "1"))

(def parsereq (xs)
  (let (type op args n cooks ip . more) xs
    (the-req* (inst 'request 'type type 'op op 'args args 'cooks cooks 'n n 'ip ip 'more more))
    xs))

(def parseheader (lines (o ip))
  (the-header* lines)
  (let (type op args) (parseurl (car lines))
    (parsereq
      (list type
            op
            (+ args
               (rem nil (map [when (begins _ "X-Arc-")
                               (tokens _ [or (whitec _) (is _ #\:)])]
                             (cdr lines))))
            (and (is type 'post)
                 (some (fn (s)
                         (and (begins s "Content-Length:")
                              (errsafe:coerce (cadr (tokens s)) 'int)))
                       (cdr lines)))
            (some (fn (s)
                    (and (or (begins s "Cookie:")
                             (begins s "cookie:"))
                         (parsecookies s)))
                  (cdr lines))
            (or (some (fn (s)
                         (and (begins s "CF-Connecting-IP:")
                              (errsafe:cadr (tokens s))))
                       (cdr lines))
                 ip)))))

; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))

(def parseurl (s)
  (let (type url) (tokens s)
    (let (base args) (tokens url #\?)
      (list (sym (downcase type))
            (sym (cut base 1))
            (if args
                (parseargs args)
                nil)))))

; I don't urldecode field names or anything in cookies; correct?

(def parseargs (s)
  (map (fn ((k v)) (list k (urldecode v)))
       (map [tokens _ #\=] (tokens s #\&))))

(def parsecookies (s)
  (map [tokens _ #\=]
       (cdr (tokens s [or (whitec _) (is _ #\;)]))))

(def arg (req key) (alref req!args key))

; *** Warning: does not currently urlencode args, so if need to do
; that replace v with (urlencode v).

(def reassemble-args (req)
  (aif req!args
       (apply string "?" (intersperse '&
                                      (map (fn ((k v))
                                             (string k '= v))
                                           it)))
       ""))

(^ fns* (table) fnids* nil timed-fnids* nil)

; count on huge (expt 64 10) size of fnid space to avoid clashes

(def new-fnid ()
  (check (sym:rand-string 22) ~fns* (new-fnid)))

(def fnid (f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push key fnids*)
    key))

(def timed-fnid (lasts f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push (list key (seconds) lasts) timed-fnids*)
    key))

; Within f, it will be bound to the fn's own fnid.  Remember that this is
; so low-level that need to generate the newline to separate from the headers
; within the body of f.

(mac afnid (f)
  `(atlet it (new-fnid)
     (= (fns* it) ,f)
     (push it fnids*)
     it))

;(defop test-afnid req
;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
;    (pr "click here")))

; To be more sophisticated, instead of killing fnids, could first
; replace them with fns that tell the server it's harvesting too
; aggressively if they start to get called.  But the right thing to
; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.

(def harvest-fnids ((o n 50000))  ; was 20000
  (when (len> fns* n)
    (pull (fn ((id created lasts))
            (when (> (since created) lasts)
              (wipe (fns* id))
              t))
          timed-fnids*)
    (atlet nharvest (trunc (/ n 10))
      (let (kill keep) (split (rev fnids*) nharvest)
        (= fnids* (rev keep))
        (each id kill
          (wipe (fns* id)))))))

(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")

(= todo-msg* (tostring:gentag img src "/todo.gif" width 18 height 18)
   dead-msg* (+ "\nUnknown or expired link. " (tostring:br) todo-msg*))

(defop-raw x (str req)
  (w/stdout str
    (aif (fns* (sym (arg req "fnid")))
         (it req)
         (pr dead-msg*))))

(defopr-raw y (str req)
  (aif (fns* (sym (arg req "fnid")))
       (w/stdout str (it req))
       "deadlink"))

; For asynchronous calls; discards the page.  Would be better to tell
; the fn not to generate it.

(defop-raw a (str req)
  (aif (fns* (sym (arg req "fnid")))
       (tostring (it req))))

(defopr r req
  (aif (fns* (sym (arg req "fnid")))
       (it req)
       "deadlink"))

(defop deadlink req
  (pr dead-msg*))

(def url-for (fnid)
  (string fnurl* "?fnid=" fnid))

(def flink (f)
  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))

(def rflink (f)
  (string rfnurl* "?fnid=" (fnid f)))

; Since it's just an expr, gensym a parm for (ignored) args.

(mac w/link (expr . body)
  `(tag (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(mac w/rlink (expr . body)
  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
     ,@body))

(mac onlink (text . body)
  `(w/link (do ,@body) (pr ,text)))

(mac onrlink (text . body)
  `(w/rlink (do ,@body) (pr ,text)))

; bad to have both flink and linkf; rename flink something like fnid-link

(mac linkf (text parms . body)
  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))

(mac rlinkf (text parms . body)
  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))

;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))

;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))

(mac w/link-if (test expr . body)
  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(def fnid-field (id)
  (gentag input type 'hidden name 'fnid value id))

; f should be a fn of one arg, which will be http request args.

(def fnform (f bodyfn (o redir))
  (tag (form method 'post action (if redir rfnurl2* fnurl*))
    (fnid-field (fnid f))
    (bodyfn)))

; Could also make a version that uses just an expr, and var capture.
; Is there a way to ensure user doesn't use "fnid" as a key?

(mac aform (f . body)
  (w/uniq ga
    `(tag (form method 'post action fnurl*)
       (fnid-field (fnid (fn (,ga)
                           (prn)
                           (,f ,ga))))
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prn) (pr req))
;          (fn () (single-input "" 'foo 20 "submit"))))

;(defop test2 req
;  (aform (fn (req) (pr req))
;    (single-input "" 'foo 20 "submit")))

; Like aform except creates a fnid that will last for lasts seconds
; (unless the server is restarted).

(mac taform (lasts f . body)
  (w/uniq (gl gf gi ga)
    `(withs (,gl ,lasts
             ,gf (fn (,ga) (prn) (,f ,ga)))
       (tag (form method 'post action fnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac arform (f . body)
  `(tag (form method 'post action rfnurl*)
     (fnid-field (fnid ,f))
     ,@body))

; overlong

(mac tarform (lasts f . body)
  (w/uniq (gl gf)
    `(withs (,gl ,lasts ,gf ,f)
       (tag (form method 'post action rfnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac aformh (f . body)
  `(tag (form method 'post action fnurl*)
     (fnid-field (fnid ,f))
     ,@body))

(mac arformh (f . body)
  `(tag (form method 'post action rfnurl2*)
     (fnid-field (fnid ,f))
     ,@body))

; only unique per server invocation

(^ unique-ids* (table))

(def unique-id ((o len 32))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
        (unique-id)
        (= (unique-ids* id) id))))

(def srvlog (type . args)
  (w/appendfile o (logfile-name type)
    (w/stdout o (atomic (apply prs (seconds) args) (prn)))))

(def logfile-name (type)
  (string logdir* type "-" (memodate)))

(with (lastasked nil lastval nil)

(def memodate ()
  (let now (seconds)
    (if (or (no lastasked) (> (- now lastasked) 60))
        (= lastasked now lastval (datestring))
        lastval)))

)

(unless (srvops* '||)
  (defop || req (pr "It's alive.")))

(defop topips req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (each ip (let leaders nil
                   (maptable (fn (ip n)
                               (when (> n 100)
                                 (insort (compare > requests/ip*)
                                         ip
                                         leaders)))
                             requests/ip*)
                   leaders)
          (let n (requests/ip* ip)
            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))

(defop spurned req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (map (fn ((ip n)) (row ip n))
             (sortable spurned*))))))

; eventually promote to general util

(def sortable (ht (o f >))
  (let res nil
    (maptable (fn kv
                (insort (compare f cadr) kv res))
              ht)
    res))

; Background Threads

(^ bgthreads* (table) pending-bgthreads* nil)

(def new-bgthread (id f sec)
  (aif (bgthreads* id) (break-thread it))
  (= (bgthreads* id) (new-thread (fn ()
                                   (while t
                                     (sleep sec)
                                     (f))))))

; should be a macro for this?

(mac defbg (id sec . body)
  `(do (pull [caris _ ',id] pending-bgthreads*)
       (push (list ',id (fn () ,@body) ,sec)
             pending-bgthreads*)))

; reload changed code each request

(def noisy-reload ()
  (awhen (any:reload)
    (write it)
    (prn)))

(when (readenv "DEV" nil)
  (defhook respond (str op args cooks ips . rest)
    (let (op args) (parseop op args)
      (when (srvops* op)
        (prn op)
        (noisy-reload)))
    nil))

; pull from github periodically

(^ git-pull-time* (readenv "PULL" nil)
   git-pull-count* 0)

(def git-pull-reload ()
  (when (errsafe:git-pull)
    (when (readenv "NUKE")
      (errsafe:git-reset-to-origin t))
    (++ git-pull-count*))
  (errsafe:reload))

(def git-pull-stats ()
  (git-pull-reload)
  (cons git-pull-count* (reload-stats)))

(awhen git-pull-time*
  (defbg git-pull it (git-pull-reload)))

; Idea: make form fields that know their value type because of
; gensymed names, and so the receiving fn gets args that are not
; strings but parsed values.

; HTTP Server.

; To improve performance with static files, set static-max-age*.

(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")

(^ quitsrv* nil breaksrv* nil)

(def serve ((o port 8080))
  (wipe quitsrv*)
  (ensure-srvdirs)
  (map [apply new-bgthread _] pending-bgthreads*)
  (w/socket s port
    (setuid 2) ; XXX switch from root to pg
    (prn "ready to serve port " port)
    (flushout)
    (= currsock* s)
    (until quitsrv*
      (handle-request s breaksrv*)))
  (prn "quit server"))

(def serve1 ((o port 8080))
  (w/socket s port (handle-request s t)))

(def ensure-srvdirs ()
  (map ensure-dir (list arcdir* logdir* staticdir*)))

(^ srv-noisy* nil)

; http requests currently capped at 2 meg by socket-accept

; should threads process requests one at a time? no, then
; a browser that's slow consuming the data could hang the
; whole server.

; wait for a connection from a browser and start a thread
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.

(^ threadlife* 30  requests* 0  requests/ip* (table)
   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))

(def handle-request (s breaksrv)
  (if breaksrv
      (handle-request-1 s)
      (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (let (i o ip) (socket-accept s)
    (if (and (or (ignore-ips* ip) (abusive-ip ip))
             (++ (spurned* ip 0)))
        (force-close i o)
        (do (++ requests*)
            (++ (requests/ip* ip 0))
            (with (th1 nil th2 nil)
              (= th1 (thread
                       (after (handle-request-thread i o ip)
                              (close i o)
                              (kill-thread th2))))
              (= th2 (thread
                       (sleep threadlife*)
                       (unless (dead th1)
                         (prn "srv thread took too long for " ip))
                       (break-thread th1)
                       (force-close i o))))))))

; Returns true if ip has made req-limit* requests in less than
; req-window* seconds.  If an ip is throttled, only 1 request is
; allowed per req-window* seconds.  If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).

; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.

(^ req-times* (table) req-limit* 30 req-window* 10 dos-window* 2 dos-protection* nil)

(def abusive-ip (ip)
  (and dos-protection*
       (only.> (requests/ip* ip) 250)
       (let now (seconds)
         (do1 (if (req-times* ip)
                  (and (>= (qlen (req-times* ip))
                           (if (throttle-ips* ip) 1 req-limit*))
                       (let dt (- now (deq (req-times* ip)))
                         (if (< dt dos-window*) (set (ignore-ips* ip)))
                         (< dt req-window*)))
                  (do (= (req-times* ip) (queue))
                      nil))
              (enq now (req-times* ip))))))

(def noisy-header (lines (o label) (o footer "\n"))
  (when srv-noisy*
    (atomic
      (if label (pr label))
      (each line lines
        (prn line))
      (if footer (pr footer))
      (flushout)))
  lines)

(def handle-request-thread (i o ip)
  (with (nls 0 lines nil line nil responded nil t0 (msec))
    (after
      (whilet c (unless responded (readc i))
        (if (is c #\newline)
            (if (is (++ nls) 2)
                (withs (h (noisy-header (rev lines) (+ "Time: " (moment-ms) "\nHeader: "))
                        (type op args n cooks ip . more) (parseheader h ip))
                  (let t1 (msec)
                    (case type
                      get  (respond o op args cooks ip)
                      post (handle-post i o op args n cooks ip)
                           (respond-err o "Unknown request: " (car lines)))
                    (log-request type op args cooks ip t0 t1)
                    (set responded)))
                (do (push (string (rev line)) lines)
                    (wipe line)))
            (unless (is c #\return)
              (push c line)
              (= nls 0))))
      (close i o)))
  (harvest-fnids))

(def log-request (type op args cooks ip t0 t1)
  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
    (srvlog 'srv ip
                 parsetime
                 respondtime
                 (if (> (+ parsetime respondtime) 1000) "***" "")
                 type
                 op
                 (let arg1 (car args)
                   (if (caris arg1 "fnid") "" arg1))
                 cooks)))

; Could ignore return chars (which come from textarea fields) here by
; (unless (is c #\return) (push c line))

(def handle-post (i o op args n cooks ip)
  (if (no n)
      (respond-err o "Post request without Content-Length.")
      (let line nil
        (whilet c (and (> n 0) (readc i))
          (-- n)
          (push c line))
        (let line (string (rev line))
          (noisy-header (list line) "Post Contents: ")
          (respond o op (+ (parseargs line) args) cooks ip)))))

(^ type-header* (table))

(def gen-type-header (ctype)
  (+ "HTTP/1.0 200 OK
Content-Type: "
     ctype
     "
Connection: close"))

(= header* (gen-type-header "text/html; charset=utf-8"))
(= secure-header* "X-Frame-Options: DENY
X-Content-Type-Options: nosniff
X-XSS-Protection: 1; mode=block
Strict-Transport-Security: max-age=31556900
";Content-Security-Policy: default-src 'self'; script-src 'self' 'unsafe-inline' https://www.google.com/recaptcha/ https://www.gstatic.com/recaptcha/ https://cdnjs.cloudflare.com/; frame-src 'self' https://www.google.com/recaptcha/; style-src 'self' 'unsafe-inline'"
)

(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
     '((image/x-icon "image/x-icon")
       (image/svg "image/svg+xml")
       (image/gif "image/gif")
       (image/jpg "image/jpeg")
       (image/png "image/png")
       (text/plain "text/plain")
       (text/html "text/html; charset=utf-8")
       (text/css  "text/css")
       (text/xml  "text/xml")
       (application/json        "application/json")
       (application/javascript  "application/javascript")
       (application/manifest    "application/manifest+json")
       ))

(= rdheader* "HTTP/1.0 302 Moved")

(^ srvops* (table) redirector* (table) optimes* (table) opcounts* (table))

(def save-optime (name elapsed)
  ; this is the place to put a/b testing
  ; toggle a flag and push elapsed into one of two lists
  (++ (opcounts* name 0))
  (unless (optimes* name) (= (optimes* name) (queue)))
  (enq-limit elapsed (optimes* name) 1000))

; For ops that want to add their own headers.  They must thus remember
; to prn a blank line before anything meant to be part of the page.

(mac defop-raw (name parms . body)
  (w/uniq t1
    `(= (srvops* ',name)
        (fn ,parms
          (let ,t1 (msec)
            (do1 (do ,@body)
                 (save-optime ',name (- (msec) ,t1))))))))

(mac defopr-raw (name parms . body)
  `(= (redirector* ',name) t
      (srvops* ',name)     (fn ,parms ,@body)))

(mac defop (name parm . body)
  (w/uniq gs
    `(do (wipe (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           (w/stdout ,gs (prn) ,@body)))))

; Defines op as a redirector.  Its retval is new location.

(mac defopr (name parm . body)
  (w/uniq gs
    `(do (set (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           ,@body))))

;(mac testop (name . args) `((srvops* ',name) ,@args))

(deftem request
  args  nil
  cooks nil
  ip    nil)

(= unknown-msg* "Unknown.")
(^ max-age* (table) static-header* (table) static-max-age* nil)

(def respond (str op args cooks ip)
  (or (hook 'respond str op args cooks ip)
      (w/stdout str
        (let (op args) (parseop op args)
          (iflet f (srvops* op)
                 (let req (inst 'request 'op op 'args args 'cooks cooks 'ip ip)
                   (if (redirector* op)
                       (do (prn rdheader*)
                           (aand (or (hook 'respond-headers str req f t)
                                     (f str req)
                                     "/")
                                 (prn "Location: " it))
                           (prn))
                       (do (prn (aif (static-header* op) (gen-type-header it) header*))
                           (awhen (max-age* op)
                             (prn "Cache-Control: max-age=" it))
                           (when (srvsecure req)
                             (prn secure-header*))
                           (or (hook 'respond-headers str req f nil)
                               (f str req)))))
                 (withs (op (car (tokens op #\?))
                         filetype (static-filetype op))
                   (aif (and filetype (file-exists (string staticdir* op)))
                        (do (prn (or (static-header* op) (type-header* filetype)))
                            (awhen static-max-age*
                              (prn "Cache-Control: max-age=" it))
                            (prn)
                            (w/infile i it
                              (whilet b (readb i)
                                (writeb b str))))
                        (respond-err str unknown-msg*))))))))

(def static-filetype (sym)
  (let fname (str sym)
    (and (~find #\/ fname)
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "ico"  'image/x-icon
           "svg"  'image/svg
           "gif"  'image/gif
           "jpg"  'image/jpg
           "jpeg" 'image/jpg
           "png"  'image/png
           "css"  'text/css
           "txt"  'text/plain
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/plain
           "xml"  'text/xml
           "js"           'application/javascript
           "json"         'application/json
           "webmanifest"  'application/manifest
           ))))

(def respond-err (str msg . args)
  (w/stdout str
    (prn header*)
    (prn)
    (apply pr msg args)))

(def parseop (op args)
  (let xs (tokens op #\/)
    (if (< (len xs) 2)
        (list op args)
        (list (sym (car xs)) (join (list (list "path" (concat (cdr xs) #\/))) args)))))

(^ the-header* (make-param nil)
   the-req* (make-param nil))

(def srvsecure ((o req (the-req*)))
  (is (arg req "X-Arc-Secure") "1"))

(def parsereq (xs)
  (let (type op args n cooks ip . more) xs
    (the-req* (inst 'request 'type type 'op op 'args args 'cooks cooks 'n n 'ip ip 'more more))
    xs))

(def parseheader (lines (o ip))
  (the-header* lines)
  (let (type op args) (parseurl (car lines))
    (parsereq
      (list type
            op
            (+ (rem nil (map [when (begins _ "X-Arc-")
                               (tokens _ [or (whitec _) (is _ #\:)])]
                             (cdr lines)))
               args)
            (and (is type 'post)
                 (some (fn (s)
                         (and (begins s "Content-Length:")
                              (errsafe:coerce (cadr (tokens s)) 'int)))
                       (cdr lines)))
            (some (fn (s)
                    (and (or (begins s "Cookie:")
                             (begins s "cookie:"))
                         (parsecookies s)))
                  (cdr lines))
            (or (some (fn (s)
                         (and (begins s "CF-Connecting-IP:")
                              (errsafe:cadr (tokens s))))
                       (cdr lines))
                 ip)))))

; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))

(def parseurl (s)
  (let (type url) (tokens s)
    (let (base args) (tokens url #\?)
      (list (sym (downcase type))
            (sym (cut base 1))
            (if args
                (parseargs args)
                nil)))))

; I don't urldecode field names or anything in cookies; correct?

(def parseargs (s)
  (map (fn ((k v)) (list k (urldecode v)))
       (map [tokens _ #\=] (tokens s #\&))))

(def parsecookies (s)
  (map [tokens _ #\=]
       (cdr (tokens s [or (whitec _) (is _ #\;)]))))

(def arg (req key) (alref req!args key))

; *** Warning: does not currently urlencode args, so if need to do
; that replace v with (urlencode v).

(def reassemble-args (req)
  (aif req!args
       (apply string "?" (intersperse '&
                                      (map (fn ((k v))
                                             (string k '= v))
                                           it)))
       ""))

(^ fns* (table) fnids* nil timed-fnids* nil)

; count on huge (expt 64 10) size of fnid space to avoid clashes

(def new-fnid ()
  (check (sym:rand-string 22) ~fns* (new-fnid)))

(def fnid (f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push key fnids*)
    key))

(def timed-fnid (lasts f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push (list key (seconds) lasts) timed-fnids*)
    key))

; Within f, it will be bound to the fn's own fnid.  Remember that this is
; so low-level that need to generate the newline to separate from the headers
; within the body of f.

(mac afnid (f)
  `(atlet it (new-fnid)
     (= (fns* it) ,f)
     (push it fnids*)
     it))

;(defop test-afnid req
;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
;    (pr "click here")))

; To be more sophisticated, instead of killing fnids, could first
; replace them with fns that tell the server it's harvesting too
; aggressively if they start to get called.  But the right thing to
; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.

(def harvest-fnids ((o n 50000))  ; was 20000
  (when (len> fns* n)
    (pull (fn ((id created lasts))
            (when (> (since created) lasts)
              (wipe (fns* id))
              t))
          timed-fnids*)
    (atlet nharvest (trunc (/ n 10))
      (let (kill keep) (split (rev fnids*) nharvest)
        (= fnids* (rev keep))
        (each id kill
          (wipe (fns* id)))))))

(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")

(= todo-msg* (tostring:gentag img src "/todo.gif" width 18 height 18)
   dead-msg* (+ "\nUnknown or expired link. " (tostring:br) todo-msg*))

(defop-raw x (str req)
  (w/stdout str
    (aif (fns* (sym (arg req "fnid")))
         (it req)
         (pr dead-msg*))))

(defopr-raw y (str req)
  (aif (fns* (sym (arg req "fnid")))
       (w/stdout str (it req))
       "deadlink"))

; For asynchronous calls; discards the page.  Would be better to tell
; the fn not to generate it.

(defop-raw a (str req)
  (aif (fns* (sym (arg req "fnid")))
       (tostring (it req))))

(defopr r req
  (aif (fns* (sym (arg req "fnid")))
       (it req)
       "deadlink"))

(defop deadlink req
  (pr dead-msg*))

(def url-for (fnid)
  (string fnurl* "?fnid=" fnid))

(def flink (f)
  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))

(def rflink (f)
  (string rfnurl* "?fnid=" (fnid f)))

; Since it's just an expr, gensym a parm for (ignored) args.

(mac w/link (expr . body)
  `(tag (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(mac w/rlink (expr . body)
  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
     ,@body))

(mac onlink (text . body)
  `(w/link (do ,@body) (pr ,text)))

(mac onrlink (text . body)
  `(w/rlink (do ,@body) (pr ,text)))

; bad to have both flink and linkf; rename flink something like fnid-link

(mac linkf (text parms . body)
  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))

(mac rlinkf (text parms . body)
  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))

;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))

;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))

(mac w/link-if (test expr . body)
  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(def fnid-field (id)
  (gentag input type 'hidden name 'fnid value id))

; f should be a fn of one arg, which will be http request args.

(def fnform (f bodyfn (o redir))
  (tag (form method 'post action (if redir rfnurl2* fnurl*))
    (fnid-field (fnid f))
    (bodyfn)))

; Could also make a version that uses just an expr, and var capture.
; Is there a way to ensure user doesn't use "fnid" as a key?

(mac aform (f . body)
  (w/uniq ga
    `(tag (form method 'post action fnurl*)
       (fnid-field (fnid (fn (,ga)
                           (prn)
                           (,f ,ga))))
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prn) (pr req))
;          (fn () (single-input "" 'foo 20 "submit"))))

;(defop test2 req
;  (aform (fn (req) (pr req))
;    (single-input "" 'foo 20 "submit")))

; Like aform except creates a fnid that will last for lasts seconds
; (unless the server is restarted).

(mac taform (lasts f . body)
  (w/uniq (gl gf gi ga)
    `(withs (,gl ,lasts
             ,gf (fn (,ga) (prn) (,f ,ga)))
       (tag (form method 'post action fnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac arform (f . body)
  `(tag (form method 'post action rfnurl*)
     (fnid-field (fnid ,f))
     ,@body))

; overlong

(mac tarform (lasts f . body)
  (w/uniq (gl gf)
    `(withs (,gl ,lasts ,gf ,f)
       (tag (form method 'post action rfnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac aformh (f . body)
  `(tag (form method 'post action fnurl*)
     (fnid-field (fnid ,f))
     ,@body))

(mac arformh (f . body)
  `(tag (form method 'post action rfnurl2*)
     (fnid-field (fnid ,f))
     ,@body))

; only unique per server invocation

(^ unique-ids* (table))

(def unique-id ((o len 32))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
        (unique-id)
        (= (unique-ids* id) id))))

(def srvlog (type . args)
  (w/appendfile o (logfile-name type)
    (w/stdout o (atomic (apply prs (seconds) args) (prn)))))

(def logfile-name (type)
  (string logdir* type "-" (memodate)))

(with (lastasked nil lastval nil)

(def memodate ()
  (let now (seconds)
    (if (or (no lastasked) (> (- now lastasked) 60))
        (= lastasked now lastval (datestring))
        lastval)))

)

(unless (srvops* '||)
  (defop || req (pr "It's alive.")))

(defop topips req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (each ip (let leaders nil
                   (maptable (fn (ip n)
                               (when (> n 100)
                                 (insort (compare > requests/ip*)
                                         ip
                                         leaders)))
                             requests/ip*)
                   leaders)
          (let n (requests/ip* ip)
            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))

(defop spurned req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (map (fn ((ip n)) (row ip n))
             (sortable spurned*))))))

; eventually promote to general util

(def sortable (ht (o f >))
  (let res nil
    (maptable (fn kv
                (insort (compare f cadr) kv res))
              ht)
    res))

; Background Threads

(^ bgthreads* (table) pending-bgthreads* nil)

(def new-bgthread (id f sec)
  (aif (bgthreads* id) (break-thread it))
  (= (bgthreads* id) (new-thread (fn ()
                                   (while t
                                     (sleep sec)
                                     (f))))))

; should be a macro for this?

(mac defbg (id sec . body)
  `(do (pull [caris _ ',id] pending-bgthreads*)
       (push (list ',id (fn () ,@body) ,sec)
             pending-bgthreads*)))

; reload changed code each request

(def noisy-reload ()
  (awhen (any:reload)
    (write it)
    (prn)))

(when (readenv "DEV" nil)
  (defhook respond (str op args cooks ips . rest)
    (let (op args) (parseop op args)
      (when (srvops* op)
        (prn op)
        (noisy-reload)))
    nil))

; pull from github periodically

(^ git-pull-time* (readenv "PULL" nil)
   git-pull-count* 0)

(def git-pull-reload ()
  (when (errsafe:git-pull)
    (when (readenv "NUKE")
      (errsafe:git-reset-to-origin t))
    (++ git-pull-count*))
  (errsafe:reload))

(def git-pull-stats ()
  (git-pull-reload)
  (cons git-pull-count* (reload-stats)))

(awhen git-pull-time*
  (defbg git-pull it (git-pull-reload)))

; Idea: make form fields that know their value type because of
; gensymed names, and so the receiving fn gets args that are not
; strings but parsed values.


Minor fix

Minor fix

; Prompt: Web-based programming application.  4 Aug 06.

(= appdir* "arc/apps/")

(defop prompt req
  (let user (get-user req)
    (if (admin user)
        (prompt-page user)
        (pr "Sorry."))))

(def prompt-page (user . msg)
  (ensure-dir appdir*)
  (ensure-dir (string appdir* user))
  (whitepage
    (prbold "Prompt")
    (hspace 20)
    (pr user " | ")
    (link "logout")
    (when msg (hspace 10) (apply pr msg))
    (br2)
    (tag (table border 0 cellspacing 10)
      (each app (dir (+ appdir* user))
        (tr (td app)
            (td (ulink user 'edit   (edit-app user app)))
            (td (ulink user 'run    (run-app  user app)))
            (td (hspace 40)
                (ulink user 'delete (rem-app  user app))))))
    (br2)
    (aform (fn (req)
             (when-umatch user req
               (aif (goodname (arg req "app"))
                    (edit-app user it)
                    (prompt-page user "Bad name."))))
       (tab (row "name:" (input "app") (submit "create app"))))))

(def app-path (user app)
  (and user app (+ appdir* user "/" app)))

(def read-app (user app)
  (aand (app-path user app)
        (file-exists it)
        (readfile it)))

(def write-app (user app exprs)
  (awhen (app-path user app)
    (w/outfile o it
      (each e exprs (write e o)))))

(def rem-app (user app)
  (let file (app-path user app)
    (if (file-exists file)
        (do (rmfile (app-path user app))
            (prompt-page user "Program " app " deleted."))
        (prompt-page user "No such app."))))

(def edit-app (user app)
  (whitepage
    (pr "user: " user " app: " app)
    (br2)
    (aform (fn (req)
             (let u2 (get-user req)
               (if (is u2 user)
                   (do (when (is (arg req "cmd") "save")
                         (write-app user app (readall (arg req "exprs"))))
                       (prompt-page user))
                   (login-page 'both nil
                               (fn (u ip) (prompt-page u))))))
      (textarea "exprs" 10 82
        (pprcode (read-app user app)))
      (br2)
      (buts 'cmd "save" "cancel"))))

(def pprcode (exprs)
  (each e exprs
    (ppr e)
    (pr "\n\n")))

(def view-app (user app)
  (whitepage
    (pr "user: " user " app: " app)
    (br2)
    (tag xmp (pprcode (read-app user app)))))

(def run-app (user app)
  (let exprs (read-app user app)
    (if exprs
        (on-err (fn (c) (pr "Error: " (details c)))
          (fn () (map eval exprs)))
        (prompt-page user "Error: No application " app " for user " user))))

(^ repl-history* nil)

(defop repl req
  (if (admin (get-user req))
      (replpage req)
      (pr "Sorry.")))

(def replpage (req)
  (whitepage
    (repl (readall (or (arg req "expr") "")) "repl")))

(def repl (exprs url)
    (each expr exprs
      (on-err (fn (c) (push (list expr c t) repl-history*))
              (fn ()
                (= that (eval expr) thatexpr expr)
                (push (list expr that) repl-history*))))
    (form url
      (textarea "expr" 8 60
        (car repl-history*))
      (sp)
      (submit))
    (tag xmp
      (each (expr val err) (firstn 20 repl-history*)
        (pr "> ")
        (ppr expr)
        (prn)
        (prn (if err "Error: " "")
             (ellipsize (tostring (write val)) 800)))))

; Prompt: Web-based programming application.  4 Aug 06.

(= appdir* "arc/apps/")

(defop prompt req
  (let user (get-user req)
    (if (admin user)
        (prompt-page user)
        (pr "Sorry."))))

(def prompt-page (user . msg)
  (ensure-dir appdir*)
  (ensure-dir (string appdir* user))
  (whitepage
    (prbold "Prompt")
    (hspace 20)
    (pr user " | ")
    (link "logout")
    (when msg (hspace 10) (apply pr msg))
    (br2)
    (tag (table border 0 cellspacing 10)
      (each app (dir (+ appdir* user))
        (tr (td app)
            (td (ulink user 'edit   (edit-app user app)))
            (td (ulink user 'run    (run-app  user app)))
            (td (hspace 40)
                (ulink user 'delete (rem-app  user app))))))
    (br2)
    (aform (fn (req)
             (when-umatch user req
               (aif (goodname (arg req "app"))
                    (edit-app user it)
                    (prompt-page user "Bad name."))))
       (tab (row "name:" (input "app") (submit "create app"))))))

(def app-path (user app)
  (and user app (+ appdir* user "/" app)))

(def read-app (user app)
  (aand (app-path user app)
        (file-exists it)
        (readfile it)))

(def write-app (user app exprs)
  (awhen (app-path user app)
    (w/outfile o it
      (each e exprs (write e o)))))

(def rem-app (user app)
  (let file (app-path user app)
    (if (file-exists file)
        (do (rmfile (app-path user app))
            (prompt-page user "Program " app " deleted."))
        (prompt-page user "No such app."))))

(def edit-app (user app)
  (whitepage
    (pr "user: " user " app: " app)
    (br2)
    (aform (fn (req)
             (let u2 (get-user req)
               (if (is u2 user)
                   (do (when (is (arg req "cmd") "save")
                         (write-app user app (readall (arg req "exprs"))))
                       (prompt-page user))
                   (login-page 'both nil
                               (fn (u ip) (prompt-page u))))))
      (textarea "exprs" 10 82
        (pprcode (read-app user app)))
      (br2)
      (buts 'cmd "save" "cancel"))))

(def pprcode (exprs)
  (each e exprs
    (ppr e)
    (pr "\n\n")))

(def view-app (user app)
  (whitepage
    (pr "user: " user " app: " app)
    (br2)
    (tag xmp (pprcode (read-app user app)))))

(def run-app (user app)
  (let exprs (read-app user app)
    (if exprs
        (on-err (fn (c) (pr "Error: " (details c)))
          (fn () (map eval exprs)))
        (prompt-page user "Error: No application " app " for user " user))))

(^ repl-history* nil)

(defop repl req
  (if (admin (get-user req))
      (replpage req)
      (pr "Sorry.")))

(def replpage (req)
  (whitepage
    (repl (readall (or (arg req "expr") "")) "repl")))

(def repl (exprs url)
    (each expr exprs
      (on-err (fn (c) (push (list expr c t) repl-history*))
              (fn ()
                (= that (eval expr) thatexpr expr)
                (push (list expr that) repl-history*))))
    (form url
      (textarea "expr" 8 60
        (write (car repl-history*)))
      (sp)
      (submit))
    (tag xmp
      (each (expr val err) (firstn 20 repl-history*)
        (pr "> ")
        (ppr expr)
        (prn)
        (prn (if err "Error: " "")
             (ellipsize (tostring (write val)) 800)))))


various utility functions

various utility functions

; lib/util.arc: A collection of useful miscellanea

; Contributors:
; - Michael Arntzenius <daekharel@gmail.com>

; Persons we've shamelessly ripped off:
; - Conan Dalton <conan@conandalton.net>
; - absz (http://arclanguage.org/user?id=absz)
; - fallintothis (http://arclanguage.org/user?id=fallintothis)

; License: Do what you want, but it's not my fault!
; This license applies to all code in this file UNLESS OTHERWISE NOTED.

; Feel free to make additions to this file and push them to anarki. Keep it to
; stuff that is widely applicable. Don't remove or change the semantics of stuff
; other people added. Add yourself to the contributors list above if you want.

; If you wish to use a different license, make a comment around the code you've
; contributed noting the license. No licenses that don't permit modification
; (duh) and redistribution (double duh).

; Try and keep track of what is whose in sections with unknown licenses
; ("ripoffs").

; miscellaneous

(def fst (a . _) " Returns its first argument. See also [[snd]] " a)
(def snd (a b . _) " Returns its second argument. See also [[fst]] " b)

(def bool (x)
  " Returns `t' if x is not nil, and `nil' otherwise. "
  (if x t))

(def uniqs (lst)
  " Returns a list of gensyms, one for each element of `lst'. Elements
    of `lst' that are symbols are used as the base names for their
    corresponding gensyms.
    See also [[uniq]] "
  (map1 (iff asym uniq [uniq]) lst))

; type checkers
(def asym (x) " `t' iff `x' is a symbol. " (isa x 'sym))
(def astring (x) " `t' iff `x' is a string. " (isa x 'string))
(def atable (x) " `t' iff `x' is a table. " (isa x 'table))
(def aint (x) " `t' iff `x' is an int. " (isa x 'int))
(def anum (x) " `t' iff `x' is a num. Note that ints are not nums. "
  (isa x 'num))

; list manipulation

; 'reduce and 'rreduce have somewhat quirky behavior, well-suited to arithmetic
; functions, but otherwise hard to reason about. I usually prefer 'foldl and
; 'foldr.
(def foldl (f v l)
  (if l (foldl f (f v car.l) cdr.l) v))

(def foldr (f v l)
  (foldl flip.f v rev.l))

(def foot (l)
  " Gets the last cons in a proper list. (Fails on dotted lists.) "
  (aif cdr.l foot.it l))

(def join/d ls
  " Destructive join.
    See also [[join]]"
  (foldr (afn (a b) (if b (aif foot.a (do (scdr it b) a) b) a)) nil ls))

(def partition (test seq)
  " Equivalent to but more efficient than
   `(list (keep test seq) (rem test seq))'. See also [[keep]] [[rem]] "
  (let (passed failed) nil
    (each e seq
      (if test.e
        (push e passed)
        (push e failed)))
    (list rev.passed rev.failed)))

(def zip ls
  " Returns a list of lists; the n-th element of the result is a list of the
    n-th elements of the lists in `ls'. The length of the result is the length
    of the shortest list in `ls'; extra elements in other lists are discarded. "
  (apply map list ls))

(def unzip (xs)
  (let ret '()
    (each i (range 0 (- (len (car xs)) 1))
      (push (map [_ i] xs) ret))
    (rev ret)))

(def mklist (x)
  " Wraps atoms in a list; does nothing if `x' is already a list."
  (check x alist list.x))

; combinators

(def applied (f)
  " Returns a fn that calls `f' on the list of its arguments.
    For example, 'max is equivalent to `(applied [best > _])'. "
  (fn a (f a)))

(def flip (f)
  " Flips the order of the first two arguments of `f'.
    For example: ((flip cons) 1 2) => (2 . 1) "
  (fn (x y . zs) (apply f y x zs)))

(def curry (f . xs)
  " Partially applies (\"curries\") `f' to `xs'. "
  (fn ys (apply f (join xs ys))))

(def const (x)
  " Creates a fn that takes any number of arguments and returns `x'. "
  (fn _ x))

(def tfn _ " Ignores its arguments and returns t. " t)
(def nilfn _ " Ignores its arguments and returns nil. " nil)

(def norf fns
  " Creates a function which returns `t' iff none of `fns' return `t'
    on its arguments.
    See also [[orf]] [[andf]] [[nor]] "
  (complement (apply orf fns)))

(def iff funs
  " Put simply: iff is to if as andf is to and. Specifically:

    (iff) => idfn
    (iff fun) => fun
    (iff test fun rest ...) => a fn that applies `fun' to its arguments if they
    pass `test', otherwise applies `(iff rest...)' to them.

    Examples:

      arc> ((iff alist car) '(x))
      x
      arc> ((iff alist car) 2)
      2
      arc> ((iff < (fn (x y) x) (fn (x y) y)) 1 2)
      1

    See also [[andf]] [[orf]] [[check]] [[idfn]] "
  (case len.funs
    0 idfn
    1 funs.0
      (withs ((test fun . rest) funs
              restfun (apply iff rest))
        (fn a (if (apply test a) (apply fun a)
                  (apply restfun a))))))

; macros

(mac mapeach (var lst . body)
  " Maps `(fn (,var) ,@body)' over `lst'.
    See also [[each]] [[map]] [[mappendeach]] "
  `(map (fn (,var) ,@body) ,lst))

(mac mappendeach (var lst . body)
  " As 'mapeach, but using 'mappend instead of 'map.
    See also [[mapeach]] [[mappend]] [[each]] "
  `(mappend (fn (,var) ,@body) ,lst))

(mac ado body
  " Anaphoric do.
    See also [[aif]] [[awhen]] [[aand]] "
  (aif cdr.body `(let it ,car.body (ado ,@it))
       car.body))

; now that pg has renamed 'assert to 'set, we're free to use it in its more
; conventional sense
(mac assert (exp (o msg (+ "Assertion failed: "
                           (tostring:ppr exp (len "Assertion failed: ") t))))
  " Errors with `msg' if `exp' evaluates to nil. "
  `(unless ,exp (err ,msg)))

(mac asserts args
  " Asserts each expr in `args', with the default error message. "
  `(do ,@(map [list 'assert _] args)))

(mac switchlet (var expr . cases)
  " Like 'caselet, except it (lazily) evals the expressions compared against.
    See also [[switch]] [[caselet]] [[case]]"
  `(let ,var ,expr
     ,((afn (args)
         (if (no cdr.args) car.args
           `(if (is ,var ,car.args) ,cadr.args
              ,(self cddr.args)))) cases)))

(mac switch (expr . cases)
  " 'switch is to 'switchlet as 'case is to 'caselet.
    See also [[switchlet]] [[case]] [[caselet]]"
  `(switchlet ,(uniq) ,exp ,@cases))

(mac dol (parms (test result) . body)
  " Like the standard lisp/scheme do loop, but with redundant inner parens
    removed."
  (w/uniq loop-name
    (let parms (tuples parms 3)
      `((rfn ,loop-name ,(map1 [_ 0] parms)
          (if ,test ,result
            (do ,@body (,loop-name ,@(map1 [_ 2] parms)))))
         ,@(map1 [_ 1] parms)))))

(mac w/stdoutfile (name . body)
  " Redirects stdout to the file `name' within `body'.
    See also [[w/stdinfile]] [[w/outfile]] [[w/stdout]] "
  (w/uniq str `(w/outfile ,str ,name (w/stdout ,str ,@body))))

(mac w/stdinfile (name . body)
  " Redirects standard input from the file `name' within `body'.
    See also [[w/stdoutfile]] [[w/infile]] [[w/stdin]] "
  (w/uniq str `(w/infile ,str ,name (w/stdin ,str ,@body))))

; binding forms

(mac with/p (vars-vals . body)
  " Scheme/Common Lisp's `let' - ie: 'with with the parens added back.
    Easier to use in macro expansions than 'with.
    See also [[with]] [[withs/p]] "
  `(with ,(apply join vars-vals) ,@body))

(mac withs/p (vars-vals . body)
  " Like Scheme/Common Lisp's `let*' - ie: 'withs with the parens added back.
    Easier to use in macro expansions than 'withs.
    See also [[withs]] [[with/p]] "
  `(withs ,(apply join vars-vals) ,@body))

; a 'with that works for defining recursive fns
(mac withr/p (bindings . body)
  " Scheme's 'letrec.
    See also [[withr]] "
  `(let ,(map1 car bindings) nil
     ,@(map [cons 'assign _] bindings)
     ,@body))

(mac withr (bindings . body)
  " Scheme's 'letrec, with the redundant inner parens removed.
    See also [[withf]] [[letf]] [[withr/p]] "
  `(withr/p ,pair.bindings ,@body))

; mutually recursive local fns
(mac withf/p (fns . body)
  " Like 'withf, only with extra parens, as in 'with/p compared to 'with.
    See also [[withf]] [[with/p]] [[withr]] [[withr/p]] "
  `(withr/p ,(mapeach (name . rest) fns `(,name (fn ,@rest)))
     ,@body))

(mac withf (fns . body)
  " Defines a set `fns' of mutually recursive local fns within `body'. Each
    three elements of `fn' correspond to a fn name, argument list, and body,
    so you'll need to use 'do if you want a multi-expression fn body.
    Example:

      arc> (withf (is-even (x) (case x 0 t (is-odd (- x 1)))
                   is-odd (x) (case x 0 nil (is-even (- x 1))))
             (keep is-odd (range 0 5)))
      (1 3 5)

    See also [[letf]] [[withr]] "
  `(withf/p ,(tuples fns 3) ,@body))

(mac letf (name args expr . body)
  " Defines a (possibly recursive) local fn `(fn ,args ,expr)' named `name'
    within `body'. Example:

      arc> (letf last (x) (aif cdr.x last.it car.x)
             (last '(x y z)))
      z

    See also [[withf]] [[withr]] "
  `(withf (,name ,args ,expr) ,@body))

; ripoffs - licenses unknown

; once-only by fallintothis
; http://arclanguage.org/item?id=9939
; CHANGED 2009-08-20:
;   + take advantage of 'uniqs, 'with/p, 'zip
;   + wrap 'names in a list if it's an atom
;   + alter indentation slightly
;  - Michael Arntzenius

(mac once-only (names . body)
  (withs (names (check names alist list.names)
          gensyms (uniqs names))
    `(w/uniq ,gensyms
       `(with ,(list ,@(mappend list gensyms names))
          ,(with/p ,(zip names gensyms)
             ,@body)))))

; afnwith by Conan Dalton
; http://arclanguage.org/item?id=10055
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
(mac rfnwith (name withses . body)
  " Convenient wrapper for applying an rfn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (rfnwith sum (x (range 1 3))
             (iflet (a . r) x (+ a (sum r)) 0))
      6

    The above example macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       (range 1 3))

    See also [[afnwith]] [[w/rfn]] [[rfn]] "
  (let w (pair withses)
    `((rfn ,name ,(map car w) ,@body) ,@(map cadr w))))

(mac afnwith (withses . body)
  " Convenient wrapper for applying an afn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (afnwith (x (range 1 3))
             (iflet (a . r) x (+ a (self r)) 0))
      6

    See also [[rfnwith]] [[w/afn]] [[afn]] "
  `(rfnwith self ,withses ,@body))

; ripoff: w/afn, by absz
; http://arclanguage.org/item?id=10125
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius

(mac w/rfn (name withses . body)
  " Convenient wrapper for applying an rfn using preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/rfn sum (x)
               (iflet (a . r) x (+ a (sum r)) 0)))
      6

    The above example (w/rfn sum ...) macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/afn]] [[rfnwith]] [[rfn]] "
  `(rfnwith ,name ,(mappend [list _ _] mklist.withses) ,@body))

(mac w/afn (withses . body)
  " Convenient wrapper for applying an afn using the preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/afn (x)
               (iflet (a . r) x (+ a (self r)) 0)))
      6

    The above example (w/afn (x) ...) macroexpands to:

      ((afn (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/rfn]] [[afnwith]] [[afn]] "
  `(w/rfn self ,withses ,@body))

; end ripoffs

; list utils

(def butlast (x)
  (cut x 0 (- (len x) 1)))

(def many (lst)
  (if (and (acons lst) (len> lst 0))))

(def len= (num lst)
  (is num (len lst)))

(def len- (lst n)
  (- (len lst) n))

(def car< (x y)
  (< (car x) (car y)))

(def cadar (lst)
  (car (cdr (car lst))))

(def mapcar (lst)
  (map [car _] lst))

(def mapcdr (lst)
  (map [cdr _] lst))

(def rand-pos (lst)
  (if lst
      (rand-elt (range 0 (- (len lst) 1)))))

(mac pushend (elem lst)
  `(= ,lst (+ ,lst (list ,elem))))

(mac popfind (f lst)
  (w/uniq g1
    `(let ,g1 (pos ,f ,lst)
       (if ,g1 (popnth ,lst ,g1)))))

(mac popnth (lst n)
  (w/uniq g1
    `(let ,g1 (,lst ,n)
       (= ,lst (+ (cut ,lst 0 ,n) (cut ,lst (+ 1 ,n))))
       ,g1)))

(mac poprand (lst)
  (w/uniq g1
    `(if ,lst
	 (let ,g1 (rand-pos ,lst)
	   (popnth ,lst ,g1)))))

; utils for lists of hashes

(def keepkey (key lst)
  (keep [_ key] lst))

(def mapkey (key lst)
  (map [_ key] lst))

; misc

(def gc ()
  (($ collect-garbage)))

; pulled from Andrew Wilcox's site
(mac between (var expr within . body)
  (w/uniq first
    `(let ,first t
       (each ,var ,expr
         (unless ,first ,within)
         (wipe ,first)
         ,@body))))

; lib/util.arc: A collection of useful miscellanea

; Contributors:
; - Michael Arntzenius <daekharel@gmail.com>

; Persons we've shamelessly ripped off:
; - Conan Dalton <conan@conandalton.net>
; - absz (http://arclanguage.org/user?id=absz)
; - fallintothis (http://arclanguage.org/user?id=fallintothis)

; License: Do what you want, but it's not my fault!
; This license applies to all code in this file UNLESS OTHERWISE NOTED.

; Feel free to make additions to this file and push them to anarki. Keep it to
; stuff that is widely applicable. Don't remove or change the semantics of stuff
; other people added. Add yourself to the contributors list above if you want.

; If you wish to use a different license, make a comment around the code you've
; contributed noting the license. No licenses that don't permit modification
; (duh) and redistribution (double duh).

; Try and keep track of what is whose in sections with unknown licenses
; ("ripoffs").

; miscellaneous

(def fst (a . _) " Returns its first argument. See also [[snd]] " a)
(def snd (a b . _) " Returns its second argument. See also [[fst]] " b)

(def bool (x)
  " Returns `t' if x is not nil, and `nil' otherwise. "
  (if x t))

(def uniqs (lst)
  " Returns a list of gensyms, one for each element of `lst'. Elements
    of `lst' that are symbols are used as the base names for their
    corresponding gensyms.
    See also [[uniq]] "
  (map1 (iff asym uniq [uniq]) lst))

; type checkers
(def asym (x) " `t' iff `x' is a symbol. " (isa x 'sym))
(def astring (x) " `t' iff `x' is a string. " (isa x 'string))
(def atable (x) " `t' iff `x' is a table. " (isa x 'table))
(def aint (x) " `t' iff `x' is an int. " (isa x 'int))
(def anum (x) " `t' iff `x' is a num. Note that ints are not nums. "
  (isa x 'num))

; list manipulation

; 'reduce and 'rreduce have somewhat quirky behavior, well-suited to arithmetic
; functions, but otherwise hard to reason about. I usually prefer 'foldl and
; 'foldr.
(def foldl (f v l)
  (if l (foldl f (f v car.l) cdr.l) v))

(def foldr (f v l)
  (foldl flip.f v rev.l))

(def foot (l)
  " Gets the last cons in a proper list. (Fails on dotted lists.) "
  (aif cdr.l foot.it l))

(def join/d ls
  " Destructive join.
    See also [[join]]"
  (foldr (afn (a b) (if b (aif foot.a (do (scdr it b) a) b) a)) nil ls))

(def partition (test seq)
  " Equivalent to but more efficient than
   `(list (keep test seq) (rem test seq))'. See also [[keep]] [[rem]] "
  (let (passed failed) nil
    (each e seq
      (if test.e
        (push e passed)
        (push e failed)))
    (list rev.passed rev.failed)))

(def zip ls
  " Returns a list of lists; the n-th element of the result is a list of the
    n-th elements of the lists in `ls'. The length of the result is the length
    of the shortest list in `ls'; extra elements in other lists are discarded. "
  (apply map list ls))

(def mklist (x)
  " Wraps atoms in a list; does nothing if `x' is already a list."
  (check x alist list.x))

; combinators

(def applied (f)
  " Returns a fn that calls `f' on the list of its arguments.
    For example, 'max is equivalent to `(applied [best > _])'. "
  (fn a (f a)))

(def flip (f)
  " Flips the order of the first two arguments of `f'.
    For example: ((flip cons) 1 2) => (2 . 1) "
  (fn (x y . zs) (apply f y x zs)))

(def curry (f . xs)
  " Partially applies (\"curries\") `f' to `xs'. "
  (fn ys (apply f (join xs ys))))

(def const (x)
  " Creates a fn that takes any number of arguments and returns `x'. "
  (fn _ x))

(def tfn _ " Ignores its arguments and returns t. " t)
(def nilfn _ " Ignores its arguments and returns nil. " nil)

(def norf fns
  " Creates a function which returns `t' iff none of `fns' return `t'
    on its arguments.
    See also [[orf]] [[andf]] [[nor]] "
  (complement (apply orf fns)))

(def iff funs
  " Put simply: iff is to if as andf is to and. Specifically:

    (iff) => idfn
    (iff fun) => fun
    (iff test fun rest ...) => a fn that applies `fun' to its arguments if they
    pass `test', otherwise applies `(iff rest...)' to them.

    Examples:

      arc> ((iff alist car) '(x))
      x
      arc> ((iff alist car) 2)
      2
      arc> ((iff < (fn (x y) x) (fn (x y) y)) 1 2)
      1

    See also [[andf]] [[orf]] [[check]] [[idfn]] "
  (case len.funs
    0 idfn
    1 funs.0
      (withs ((test fun . rest) funs
              restfun (apply iff rest))
        (fn a (if (apply test a) (apply fun a)
                  (apply restfun a))))))

; macros

(mac mapeach (var lst . body)
  " Maps `(fn (,var) ,@body)' over `lst'.
    See also [[each]] [[map]] [[mappendeach]] "
  `(map (fn (,var) ,@body) ,lst))

(mac mappendeach (var lst . body)
  " As 'mapeach, but using 'mappend instead of 'map.
    See also [[mapeach]] [[mappend]] [[each]] "
  `(mappend (fn (,var) ,@body) ,lst))

(mac ado body
  " Anaphoric do.
    See also [[aif]] [[awhen]] [[aand]] "
  (aif cdr.body `(let it ,car.body (ado ,@it))
       car.body))

; now that pg has renamed 'assert to 'set, we're free to use it in its more
; conventional sense
(mac assert (exp (o msg (+ "Assertion failed: "
                           (tostring:ppr exp (len "Assertion failed: ") t))))
  " Errors with `msg' if `exp' evaluates to nil. "
  `(unless ,exp (err ,msg)))

(mac asserts args
  " Asserts each expr in `args', with the default error message. "
  `(do ,@(map [list 'assert _] args)))

(mac switchlet (var expr . cases)
  " Like 'caselet, except it (lazily) evals the expressions compared against.
    See also [[switch]] [[caselet]] [[case]]"
  `(let ,var ,expr
     ,((afn (args)
         (if (no cdr.args) car.args
           `(if (is ,var ,car.args) ,cadr.args
              ,(self cddr.args)))) cases)))

(mac switch (expr . cases)
  " 'switch is to 'switchlet as 'case is to 'caselet.
    See also [[switchlet]] [[case]] [[caselet]]"
  `(switchlet ,(uniq) ,exp ,@cases))

(mac dol (parms (test result) . body)
  " Like the standard lisp/scheme do loop, but with redundant inner parens
    removed."
  (w/uniq loop-name
    (let parms (tuples parms 3)
      `((rfn ,loop-name ,(map1 [_ 0] parms)
          (if ,test ,result
            (do ,@body (,loop-name ,@(map1 [_ 2] parms)))))
         ,@(map1 [_ 1] parms)))))

(mac w/stdoutfile (name . body)
  " Redirects stdout to the file `name' within `body'.
    See also [[w/stdinfile]] [[w/outfile]] [[w/stdout]] "
  (w/uniq str `(w/outfile ,str ,name (w/stdout ,str ,@body))))

(mac w/stdinfile (name . body)
  " Redirects standard input from the file `name' within `body'.
    See also [[w/stdoutfile]] [[w/infile]] [[w/stdin]] "
  (w/uniq str `(w/infile ,str ,name (w/stdin ,str ,@body))))

; binding forms

(mac with/p (vars-vals . body)
  " Scheme/Common Lisp's `let' - ie: 'with with the parens added back.
    Easier to use in macro expansions than 'with.
    See also [[with]] [[withs/p]] "
  `(with ,(apply join vars-vals) ,@body))

(mac withs/p (vars-vals . body)
  " Like Scheme/Common Lisp's `let*' - ie: 'withs with the parens added back.
    Easier to use in macro expansions than 'withs.
    See also [[withs]] [[with/p]] "
  `(withs ,(apply join vars-vals) ,@body))

; a 'with that works for defining recursive fns
(mac withr/p (bindings . body)
  " Scheme's 'letrec.
    See also [[withr]] "
  `(let ,(map1 car bindings) nil
     ,@(map [cons 'assign _] bindings)
     ,@body))

(mac withr (bindings . body)
  " Scheme's 'letrec, with the redundant inner parens removed.
    See also [[withf]] [[letf]] [[withr/p]] "
  `(withr/p ,pair.bindings ,@body))

; mutually recursive local fns
(mac withf/p (fns . body)
  " Like 'withf, only with extra parens, as in 'with/p compared to 'with.
    See also [[withf]] [[with/p]] [[withr]] [[withr/p]] "
  `(withr/p ,(mapeach (name . rest) fns `(,name (fn ,@rest)))
     ,@body))

(mac withf (fns . body)
  " Defines a set `fns' of mutually recursive local fns within `body'. Each
    three elements of `fn' correspond to a fn name, argument list, and body,
    so you'll need to use 'do if you want a multi-expression fn body.
    Example:

      arc> (withf (is-even (x) (case x 0 t (is-odd (- x 1)))
                   is-odd (x) (case x 0 nil (is-even (- x 1))))
             (keep is-odd (range 0 5)))
      (1 3 5)

    See also [[letf]] [[withr]] "
  `(withf/p ,(tuples fns 3) ,@body))

(mac letf (name args expr . body)
  " Defines a (possibly recursive) local fn `(fn ,args ,expr)' named `name'
    within `body'. Example:

      arc> (letf last (x) (aif cdr.x last.it car.x)
             (last '(x y z)))
      z

    See also [[withf]] [[withr]] "
  `(withf (,name ,args ,expr) ,@body))

; ripoffs - licenses unknown

; once-only by fallintothis
; http://arclanguage.org/item?id=9939
; CHANGED 2009-08-20:
;   + take advantage of 'uniqs, 'with/p, 'zip
;   + wrap 'names in a list if it's an atom
;   + alter indentation slightly
;  - Michael Arntzenius

(mac once-only (names . body)
  (withs (names (check names alist list.names)
          gensyms (uniqs names))
    `(w/uniq ,gensyms
       `(with ,(list ,@(mappend list gensyms names))
          ,(with/p ,(zip names gensyms)
             ,@body)))))

; afnwith by Conan Dalton
; http://arclanguage.org/item?id=10055
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
(mac rfnwith (name withses . body)
  " Convenient wrapper for applying an rfn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (rfnwith sum (x (range 1 3))
             (iflet (a . r) x (+ a (sum r)) 0))
      6

    The above example macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       (range 1 3))

    See also [[afnwith]] [[w/rfn]] [[rfn]] "
  (let w (pair withses)
    `((rfn ,name ,(map car w) ,@body) ,@(map cadr w))))

(mac afnwith (withses . body)
  " Convenient wrapper for applying an afn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (afnwith (x (range 1 3))
             (iflet (a . r) x (+ a (self r)) 0))
      6

    See also [[rfnwith]] [[w/afn]] [[afn]] "
  `(rfnwith self ,withses ,@body))

; ripoff: w/afn, by absz
; http://arclanguage.org/item?id=10125
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius

(mac w/rfn (name withses . body)
  " Convenient wrapper for applying an rfn using preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/rfn sum (x)
               (iflet (a . r) x (+ a (sum r)) 0)))
      6

    The above example (w/rfn sum ...) macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/afn]] [[rfnwith]] [[rfn]] "
  `(rfnwith ,name ,(mappend [list _ _] mklist.withses) ,@body))

(mac w/afn (withses . body)
  " Convenient wrapper for applying an afn using the preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/afn (x)
               (iflet (a . r) x (+ a (self r)) 0)))
      6

    The above example (w/afn (x) ...) macroexpands to:

      ((afn (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/rfn]] [[afnwith]] [[afn]] "
  `(w/rfn self ,withses ,@body))

; end ripoffs

(def butlast (x)
  (cut x 0 (- (len x) 1)))

(def joinstr (lst (o glue " "))
  (let lst (keep [len> _ 0] lst)
    (if lst
  (apply + (intersperse (string glue) lst))
  "")))


stop loading http.arc as well

stop loading http.arc as well

http/dispatch.arc are the srv/app.arc alternative.

(map load '("strings.arc"
            "code.arc"
            "html.arc"
            "srv.arc"
            "app.arc"
            "prompt.arc"))

; We define 'require here, rather than in a file in load/ so that things in
; load/ can use it for load-ordering.
(unless (and (bound 'required-files*) required-files*)
  (= required-files* (table)))

(def require (file)
  " Loads `file' if it has not yet been `require'd.  Can be fooled by changing
    the name ((require \"foo.arc\") as opposed to (require \"./foo.arc\")), but
    this should not be a problem.
    See also [[load]]. "
  (or (required-files* file)
    (do (set required-files*.file)
        (load file))))

(def autoload ((o dirname "load"))
  " 'require each file in `dirname' ending in \".arc\".
    See also [[require]] "
  (each f (dir-exists&dir dirname)
    (if (endmatch ".arc" f) (require (+ dirname "/" f)))))

(autoload)

(map load '("strings.arc"
            "code.arc"
            "html.arc"
            "srv.arc"
            "app.arc"
            "http.arc"
            "prompt.arc"))

; We define 'require here, rather than in a file in load/ so that things in
; load/ can use it for load-ordering.
(unless (and (bound 'required-files*) required-files*)
  (= required-files* (table)))

(def require (file)
  " Loads `file' if it has not yet been `require'd.  Can be fooled by changing
    the name ((require \"foo.arc\") as opposed to (require \"./foo.arc\")), but
    this should not be a problem.
    See also [[load]]. "
  (or (required-files* file)
    (do (set required-files*.file)
        (load file))))

(def autoload ((o dirname "load"))
  " 'require each file in `dirname' ending in \".arc\".
    See also [[require]] "
  (each f (dir-exists&dir dirname)
    (if (endmatch ".arc" f) (require (+ dirname "/" f)))))

(autoload)