utf8 support for urlencode

utf8 support for urlencode

; Matching.  Spun off 29 Jul 06.

; arc> (tostring (writec (coerce 133 'char)))
;
;> (define ss (open-output-string))
;> (write-char (integer->char 133) ss)
;> (get-output-string ss)
;"\u0085"

(def tokens (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs toks tok)
               (if (no cs)         (consif tok toks)
                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
                                   (self (cdr cs) toks (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (map rev (rec (coerce s 'cons) nil nil)))))))

; names of cut, split, halve not optimal

(def halve (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs tok)
               (if (no cs)         (list (rev tok))
                   (test (car cs)) (list cs (rev tok))
                                   (self (cdr cs) (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (rec (coerce s 'cons) nil))))))

; maybe promote to arc.arc, but if so include a list clause

(def positions (test seq)
  (accum a
    (let f (testify test)
      (forlen i seq
        (if (f (seq i)) (a i))))))

(def lines (s)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (rem #\return (cut s (+ p 1) (car ps))))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions #\newline s)))))

(def slices (s test)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (cut s (+ p 1) (car ps)))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions test s)))))

; > (require (lib "uri-codec.ss" "net"))
;> (form-urlencoded-decode "x%ce%bbx")
;"xλx"

; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.

; Fixed for utf8 by pc.

(def urldecode (s)
 (tostring
  (forlen i s
    (caselet c (s i)
      #\+ (writec #\space)
      #\% (do (when (> (- (len s) i) 2)
                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
              (++ i 2))
          (writec c)))))

(def urlencode (s)
  (tostring
    (each c (utf-8-bytes s)
      (writec #\%)
      (let i (int c)
        (if (< i 16) (writec #\0))
        (pr (coerce i 'string 16))))))

(mac litmatch (pat string (o start 0))
  (w/uniq (gstring gstart)
    `(with (,gstring ,string ,gstart ,start)
       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
                           acc))
                  (rev acc)))))))

; litmatch would be cleaner if map worked for string and integer args:

;             ,@(map (fn (n c)
;                      `(is ,c (,gstring (+ ,gstart ,n))))
;                    (len pat)
;                    pat)

(mac endmatch (pat string)
  (w/uniq (gstring glen)
    `(withs (,gstring ,string ,glen (len ,gstring))
       (unless (> ,(len pat) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat (- (len pat) 1 i))
                               (,gstring (- ,glen 1 ,i)))
                           acc))
                  (rev acc)))))))

(def posmatch (pat seq (o start 0))
  (catch
    (if (isa pat 'fn)
        (for i start (- (len seq) 1)
          (when (pat (seq i)) (throw i)))
        (for i start (- (len seq) (len pat))
          (when (headmatch pat seq i) (throw i))))
    nil))

(def headmatch (pat seq (o start 0))
  (let p (len pat)
    ((afn (i)
       (or (is i p)
           (and (is (pat i) (seq (+ i start)))
                (self (+ i 1)))))
     0)))

(def begins (seq pat (o start 0))
  (unless (len> pat (- (len seq) start))
    (headmatch pat seq start)))

(def subst (new old seq)
  (let boundary (+ (- (len seq) (len old)) 1)
    (tostring
      (forlen i seq
        (if (and (< i boundary) (headmatch old seq i))
            (do (++ i (- (len old) 1))
                (pr new))
            (pr (seq i)))))))

(def multisubst (pairs seq)
  (tostring
    (forlen i seq
      (iflet (old new) (find [begins seq (car _) i] pairs)
        (do (++ i (- (len old) 1))
            (pr new))
        (pr (seq i))))))

; not a good name

(def findsubseq (pat seq (o start 0))
  (if (< (- (len seq) start) (len pat))
       nil
      (if (headmatch pat seq start)
          start
          (findsubseq pat seq (+ start 1)))))

(def blank (s) (~find ~whitec s))

(def nonblank (s) (unless (blank s) s))

(def trim (s (o where 'both) (o test whitec))
  (withs (f   (testify test)
           p1 (pos ~f s))
    (if p1
        (cut s
             (if (in where 'front 'both) p1 0)
             (when (in where 'end 'both)
               (let i (- (len s) 1)
                 (while (and (> i p1) (f (s i)))
                   (-- i))
                 (+ i 1))))
        "")))

(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
  (withs (comma
          (fn (i)
            (tostring
              (map [apply pr (rev _)]
                   (rev (intersperse '(#\,)
                                     (tuples (rev (coerce (string i) 'cons))
                                             3))))))
          abrep
          (let a (abs n)
            (if (< digits 1)
                 (comma (roundup a))
                (exact a)
                 (string (comma a)
                         (when (and trail-zeros (> digits 0))
                           (string "." (newstring digits #\0))))
                 (withs (d (expt 10 digits)
                         m (/ (roundup (* a d)) d)
                         i (trunc m)
                         r (abs (trunc (- (* m d) (* i d)))))
                   (+ (if (is i 0)
                          (if (or init-zero (is r 0)) "0" "")
                          (comma i))
                      (withs (rest   (string r)
                              padded (+ (newstring (- digits (len rest)) #\0)
                                        rest)
                              final  (if trail-zeros
                                         padded
                                         (trim padded 'end [is _ #\0])))
                        (string (unless (empty final) ".")
                                final)))))))
    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
        (+ "-" abrep)
        abrep)))

(def joinstr (lst (o glue " "))
  (string (intersperse glue lst)))

; by Andrew Wilcox
(def begins-rest (pattern s)
  (if (begins s pattern)
      (cut s (len pattern))))

; English

(def pluralize (n str)
  (if (or (is n 1) (single n))
      str
      (string str "s")))

(def plural (n x)
  (string n #\  (pluralize n x)))

(def capitalize (str)
  (if (empty str) str
      (+ (upcase (str 0)) (cut str 1))))

(load "help/strings.arc")

; http://www.eki.ee/letter/chardata.cgi?HTML4=1
; http://jrgraphix.net/research/unicode_blocks.php?block=1
; http://home.tiscali.nl/t876506/utf8tbl.html
; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
; http://en.wikipedia.org/wiki/Utf-8
; http://unicode.org/charts/charindex2.html

; Matching.  Spun off 29 Jul 06.

; arc> (tostring (writec (coerce 133 'char)))
;
;> (define ss (open-output-string))
;> (write-char (integer->char 133) ss)
;> (get-output-string ss)
;"\u0085"

(def tokens (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs toks tok)
               (if (no cs)         (consif tok toks)
                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
                                   (self (cdr cs) toks (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (map rev (rec (coerce s 'cons) nil nil)))))))

; names of cut, split, halve not optimal

(def halve (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs tok)
               (if (no cs)         (list (rev tok))
                   (test (car cs)) (list cs (rev tok))
                                   (self (cdr cs) (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (rec (coerce s 'cons) nil))))))

; maybe promote to arc.arc, but if so include a list clause

(def positions (test seq)
  (accum a
    (let f (testify test)
      (forlen i seq
        (if (f (seq i)) (a i))))))

(def lines (s)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (rem #\return (cut s (+ p 1) (car ps))))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions #\newline s)))))

(def slices (s test)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (cut s (+ p 1) (car ps)))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions test s)))))

; > (require (lib "uri-codec.ss" "net"))
;> (form-urlencoded-decode "x%ce%bbx")
;"xλx"

; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.

; Fixed for utf8 by pc.

(def urldecode (s)
 (tostring
  (forlen i s
    (caselet c (s i)
      #\+ (writec #\space)
      #\% (do (when (> (- (len s) i) 2)
                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
              (++ i 2))
          (writec c)))))

(def urlencode (s)
  (tostring
    (each c s
      (writec #\%)
      (let i (int c)
        (if (< i 16) (writec #\0))
        (pr (coerce i 'string 16))))))

(mac litmatch (pat string (o start 0))
  (w/uniq (gstring gstart)
    `(with (,gstring ,string ,gstart ,start)
       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
                           acc))
                  (rev acc)))))))

; litmatch would be cleaner if map worked for string and integer args:

;             ,@(map (fn (n c)
;                      `(is ,c (,gstring (+ ,gstart ,n))))
;                    (len pat)
;                    pat)

(mac endmatch (pat string)
  (w/uniq (gstring glen)
    `(withs (,gstring ,string ,glen (len ,gstring))
       (unless (> ,(len pat) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat (- (len pat) 1 i))
                               (,gstring (- ,glen 1 ,i)))
                           acc))
                  (rev acc)))))))

(def posmatch (pat seq (o start 0))
  (catch
    (if (isa pat 'fn)
        (for i start (- (len seq) 1)
          (when (pat (seq i)) (throw i)))
        (for i start (- (len seq) (len pat))
          (when (headmatch pat seq i) (throw i))))
    nil))

(def headmatch (pat seq (o start 0))
  (let p (len pat)
    ((afn (i)
       (or (is i p)
           (and (is (pat i) (seq (+ i start)))
                (self (+ i 1)))))
     0)))

(def begins (seq pat (o start 0))
  (unless (len> pat (- (len seq) start))
    (headmatch pat seq start)))

(def subst (new old seq)
  (let boundary (+ (- (len seq) (len old)) 1)
    (tostring
      (forlen i seq
        (if (and (< i boundary) (headmatch old seq i))
            (do (++ i (- (len old) 1))
                (pr new))
            (pr (seq i)))))))

(def multisubst (pairs seq)
  (tostring
    (forlen i seq
      (iflet (old new) (find [begins seq (car _) i] pairs)
        (do (++ i (- (len old) 1))
            (pr new))
        (pr (seq i))))))

; not a good name

(def findsubseq (pat seq (o start 0))
  (if (< (- (len seq) start) (len pat))
       nil
      (if (headmatch pat seq start)
          start
          (findsubseq pat seq (+ start 1)))))

(def blank (s) (~find ~whitec s))

(def nonblank (s) (unless (blank s) s))

(def trim (s (o where 'both) (o test whitec))
  (withs (f   (testify test)
           p1 (pos ~f s))
    (if p1
        (cut s
             (if (in where 'front 'both) p1 0)
             (when (in where 'end 'both)
               (let i (- (len s) 1)
                 (while (and (> i p1) (f (s i)))
                   (-- i))
                 (+ i 1))))
        "")))

(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
  (withs (comma
          (fn (i)
            (tostring
              (map [apply pr (rev _)]
                   (rev (intersperse '(#\,)
                                     (tuples (rev (coerce (string i) 'cons))
                                             3))))))
          abrep
          (let a (abs n)
            (if (< digits 1)
                 (comma (roundup a))
                (exact a)
                 (string (comma a)
                         (when (and trail-zeros (> digits 0))
                           (string "." (newstring digits #\0))))
                 (withs (d (expt 10 digits)
                         m (/ (roundup (* a d)) d)
                         i (trunc m)
                         r (abs (trunc (- (* m d) (* i d)))))
                   (+ (if (is i 0)
                          (if (or init-zero (is r 0)) "0" "")
                          (comma i))
                      (withs (rest   (string r)
                              padded (+ (newstring (- digits (len rest)) #\0)
                                        rest)
                              final  (if trail-zeros
                                         padded
                                         (trim padded 'end [is _ #\0])))
                        (string (unless (empty final) ".")
                                final)))))))
    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
        (+ "-" abrep)
        abrep)))

(def joinstr (lst (o glue " "))
  (string (intersperse glue lst)))

; by Andrew Wilcox
(def begins-rest (pattern s)
  (if (begins s pattern)
      (cut s (len pattern))))

; English

(def pluralize (n str)
  (if (or (is n 1) (single n))
      str
      (string str "s")))

(def plural (n x)
  (string n #\  (pluralize n x)))

(def capitalize (str)
  (if (empty str) str
      (+ (upcase (str 0)) (cut str 1))))

(load "help/strings.arc")

; http://www.eki.ee/letter/chardata.cgi?HTML4=1
; http://jrgraphix.net/research/unicode_blocks.php?block=1
; http://home.tiscali.nl/t876506/utf8tbl.html
; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
; http://en.wikipedia.org/wiki/Utf-8
; http://unicode.org/charts/charindex2.html


support for basic auth

support for basic auth

http://en.wikipedia.org/wiki/Basic_access_authentication

; 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*
      (serve-socket s breaksrv*)))
  (prn "quit server"))

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

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

(= srv-noisy* nil)

; http requests currently capped to upload-limit* bytes
; see 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 serve-socket (s breaksrv)
  (if breaksrv
    (accept-request-with-timeout s)
    (errsafe (accept-request-with-timeout s))))

(def accept-request-with-timeout (s)
  (with ((in out ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (= th1 (thread
             (after (handle-request-thread in out ip)
                    (close in out)
                    (kill-thread th2))))
    (= th2 (thread
             (sleep threadlife*)
             (unless (dead th1)
               (prn "srv thread took too long for " ip))
             (kill-thread th1)
             (force-close in out)))))

(def handle-request-thread (in out ip)
  (withs (t0 (msec)
          req parse-header.in)
    (= req!cooks (only.parse-cookies (req "cookie")))
    (aif (req "x-forwarded-for")
      (= ip it))
    (after
      (unless (abusive ip)
        (let t1 (msec)
          (if (~authorized? req)
            (request-credentials out)
            (case req!type
              get  (respond out req)
              post (handle-post in out req)
                   (respond-err out "Unknown request: " req)))
          (log-request req!type req!op req!args req!cooks ip t0 t1)))
      (close in out))
    (harvest-fnids)))

; 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)

(def abusive (ip)
  (++ (requests/ip* ip 0))
  (when (or (ignore-ips* ip) (abusive-core ip))
    (when (~spurned* ip)
      (prn "throttling abusive ip " ip))
    (++ (spurned* ip 0))))

(def abusive-core (ip)
  (and (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))))))

; basic auth support for private websites
; to enable, provide a single common user:pass in the clear for all users in this file:
(= private-credentials* (errsafe:string:fromfile (+ arcdir* "/private-credentials") (read)))

(def authorized? (req)
  (or no.private-credentials*
      (aand (req "authorization")
            (cut it (len "Basic "))
            (iso private-credentials* base64-decode.it))))

(def request-credentials (out)
  (w/stdout out
    (prrn "HTTP/1.1 401 Not Authorized")
    (prrn "WWW-Authenticate: Basic realm=\"" site-url* "\"")
    (prrn)))

($ (require net/base64))
(def base64-encode (s)
  (fromstring s
    (tostring
      ($.base64-encode-stream (stdin) (stdout)))))
(def base64-decode (s)
  (fromstring s
    (tostring
      ($.base64-decode-stream (stdin) (stdout)))))

(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)))

(def static-filetype (sym)
  (let fname (coerce sym 'string)
    (and (~findsubseq ".." fname) ; for security
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "gif"  'image/gif
           "jpg"  'image/jpg
           "jpeg" 'image/jpg
           "png"  'image/png
           "css"  'text/plain
           "js"   'text/javascript
           "txt"  'text/plain
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/plain
           ))))

(= 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 prrn 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 (prrn) ,@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))

(= max-age* (table) static-max-age* nil)

(def respond (out req)
  (w/stdout out
    (iflet f (srvops* req!op)
      (if (redirector* req!op)
        (do (prrn "HTTP/1.1 302 Moved")
            (prrn "Location: " (f out req))
            (prrn))
        (do (prrn "HTTP/1.1 200 OK")
            (prrn "Content-Type: text/html; charset=utf-8")
            (prrn "Connection: close")
            (awhen (max-age* req!op)
              (prrn "Cache-Control: max-age=" it))
            (f out req)))
      (let filetype (static-filetype req!op)
        (aif (and filetype (file-exists (string staticdir* req!op)))
          (do (prrn "HTTP/1.1 200 OK")
              (prrn "Content-Type: " filetype
                   (if (litmatch "text" filetype)
                     "; charset=utf-8"
                     ""))
              (prrn "Connection: close")
              (awhen static-max-age*
                (prrn "Cache-Control: max-age=" it))
              (prrn)
              (w/infile i it
                (whilet b (readb i)
                  (writeb b out))))
          (respond-err out "Unknown."))))))

(def handle-post (in out req)
  (iflet clen (req "content-length")
    (do (zap [errsafe:as int _] clen)
        (= req!args
           (+ req!args
              (let ctype (req "content-type")
                (if (~begins downcase.ctype "multipart/form-data")
                  (parseargs:string:readchars clen in) ; ascii
                  (parse-multipart-args multipart-boundary.ctype in))))) ; maybe non-ascii
        (respond out req))
    (respond-err out "Post request without Content-Length.")))

(def multipart-boundary (s)
  (let delim "boundary="
    (+ "--" (cut s (+ (findsubseq delim s)
                      len.delim)))))

(def parse-multipart-args (boundary in)
  (scan-past boundary in) ; skip prelude
  (accum yield
    (until (multipart-end boundary in)
      (withs (headers   scan-headers.in
              body  (scan-body boundary in)) ; only part that may contain non-ascii
        (when headers
          (yield:parse-multipart-part headers body))))))

; "The final boundary is followed by two more hyphens to indicate that no
; further parts follow."
;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
; We've already read the boundary itself.
(def multipart-end (boundary in)
  (aif peekc.in
    (and (is #\- it) readc.in
         (or (is #\- peekc.in)
             ; "one #\- shalt thou not count,
             ; excepting that thou then proceed to two"
             (ero "malformed multipart input; boundary followed by just one '-'. Is it the final part or isn't it?")))
    (ero "malformed multipart input; request didn't have a final boundary")))

(def scan-headers (in)
  ; "The boundary must be followed immediately either by another CRLF and the
  ; header fields for the next part, or by two CRLFs, in which case there are no
  ; header fields for the next part.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (parse-mime-header:bytes-string:scan-past "\r\n\r\n" in))

(def scan-body (boundary in)
  ; "The CRLF preceding the encapsulation line is considered part of the
  ; boundary.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (scan-past (+ "\r\n" boundary) in))

(def parse-multipart-part (headers body)
  (awhen (and headers (alref headers "name"))
    (list unstring.it
          (w/table multipart-arg
            (= (multipart-arg "contents")
               (if (all-ascii? body)
                 bytes-string.body
                 body))
            (each (property val) headers
              (unless (iso "name" property)
                (= multipart-arg.property val)))))))

; parse lines of the form a=b; c=d; e=f; ..
; segments without '=' are passed through as single-elem lists
(def parse-mime-header (line)
  (map [tokens _ #\=]
       (tokens downcase.line (orf whitec (testify #\;)))))

; return list of bytes until pat is encountered
; pat is read from input but dropped from result
; all chars in pat must be 1-byte
(def scan-past (pat in)
  (= pat (map int (coerce pat 'cons)))
  (let buffer (spliceable-list len.pat)
    (until (iso pat suffix.buffer)
      (append buffer (list readb.in)))
    splice.buffer))

; convert list of bytes to string
(def bytes-string (l)
  (coerce (map [coerce _ 'char]
               l)
          'string))

(def all-ascii? (l)
  (errsafe:all [<= 0 _ 127] l))

; "\"abc\"" => "abc"
(def unstring (s)
  (if (iso #\" s.0)
    (cut s 1 -1)
    s))

(def respond-err (str msg . args)
  (w/stdout str
    (prrn "HTTP/1.1 404 Not Found")
    (prrn "Content-Type: text/html; charset=utf-8")
    (prrn "Connection: close")
    (prrn)
    (apply pr msg args)))

(def parse-header ((o in (stdin)))
  (let (request-line . header-lines) read-header.in
    (as table (accum yield
      (map yield parse-cmd.request-line)
      (map yield (map split-header header-lines))))))

(def read-header ((o in (stdin)))
  (with (nls 0  lines nil  line nil)
    (forever:let c readc.in
      (if no.c (break))
      (if (is c #\return) (continue))
      (if (is c #\newline)
        (++ nls)
        (= nls 0))
      (when (>= nls 2)
        (break))
      (if (is c #\newline)
        (do (push (string rev.line) lines)
            (wipe line))
        (push c line)))
    rev.lines))

(def split-header (line)
  (whenlet n (findsubseq ": " line)
    (list (downcase:cut line 0 n)  ; normalize header key
          (cut line (+ n 2)))))

(def parse-cmd (request-line)
  (accum yield
    (let (type url) tokens.request-line
      (yield `(type ,(sym downcase.type)))
      (let (base args) (tokens url #\?)
        (yield `(op ,(sym:cut base 1)))  ; skip leading slash
        (aif args
          (yield `(args ,parseargs.it)))))))

; 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 parse-cookies (s)
  (map [tokens _ #\=]
       (tokens s [or whitec._ (is _ #\;)])))

(def arg (req key)
  (acheck (alref req!args key) [~isa _ 'table]
    ; deref multipart params by default
    (it "contents")))

(def multipart-metadata (req arg key)
  (let val (alref req!args arg)
    (if (isa val 'table)
      val.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 10)) ~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) (prrn) (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")

(= dead-msg* "\nUnknown or expired link.")

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

(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) (prrn) (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)
                           (prrn)
                           (,f ,ga))))
       ,@body)))

(mac aform-multi (f . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action (string fnurl* "?fnid="
                               (fnid (fn (,ga)
                                       (prrn)
                                       (,f ,ga)))))
       ,@body)))

(mac form-multi (action . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action ,action)
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prrn) (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) (prrn) (,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 8))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
      (unique-id)
      (= (unique-ids* id) id))))

(def srvlog (type . args)
  (ontofile (logfile-name type)
            (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)))

)

(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*)))

; 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*
      (serve-socket s breaksrv*)))
  (prn "quit server"))

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

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

(= srv-noisy* nil)

; http requests currently capped to upload-limit* bytes
; see 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 serve-socket (s breaksrv)
  (if breaksrv
    (accept-request-with-timeout s)
    (errsafe (accept-request-with-timeout s))))

(def accept-request-with-timeout (s)
  (with ((in out ip) (socket-accept s)
         th1 nil th2 nil)
    (++ requests*)
    (= th1 (thread
             (after (handle-request-thread in out ip)
                    (close in out)
                    (kill-thread th2))))
    (= th2 (thread
             (sleep threadlife*)
             (unless (dead th1)
               (prn "srv thread took too long for " ip))
             (kill-thread th1)
             (force-close in out)))))

(def handle-request-thread (in out ip)
  (withs (t0 (msec)
          req parse-header.in)
    (= req!cooks (only.parse-cookies (req "cookie")))
    (aif (req "x-forwarded-for")
      (= ip it))
    (after
      (unless (abusive ip)
        (let t1 (msec)
          (case req!type
            get  (respond out req)
            post (handle-post in out req)
                 (respond-err out "Unknown request: " req))
          (log-request req!type req!op req!args req!cooks ip t0 t1)))
      (close in out))
    (harvest-fnids)))

; 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)

(def abusive (ip)
  (++ (requests/ip* ip 0))
  (when (or (ignore-ips* ip) (abusive-core ip))
    (when (~spurned* ip)
      (prn "throttling abusive ip " ip))
    (++ (spurned* ip 0))))

(def abusive-core (ip)
  (and (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 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)))

(def static-filetype (sym)
  (let fname (coerce sym 'string)
    (and (~findsubseq ".." fname) ; for security
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "gif"  'image/gif
           "jpg"  'image/jpg
           "jpeg" 'image/jpg
           "png"  'image/png
           "css"  'text/plain
           "js"   'text/javascript
           "txt"  'text/plain
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/plain
           ))))

(= 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 prrn 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 (prrn) ,@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))

(= max-age* (table) static-max-age* nil)

(def respond (out req)
  (w/stdout out
    (iflet f (srvops* req!op)
      (if (redirector* req!op)
        (do (prrn "HTTP/1.1 302 Moved")
            (prrn "Location: " (f out req))
            (prrn))
        (do (prrn "HTTP/1.1 200 OK")
            (prrn "Content-Type: text/html; charset=utf-8")
            (prrn "Connection: close")
            (awhen (max-age* req!op)
              (prrn "Cache-Control: max-age=" it))
            (f out req)))
      (let filetype (static-filetype req!op)
        (aif (and filetype (file-exists (string staticdir* req!op)))
          (do (prrn "HTTP/1.1 200 OK")
              (prrn "Content-Type: " filetype
                   (if (litmatch "text" filetype)
                     "; charset=utf-8"
                     ""))
              (prrn "Connection: close")
              (awhen static-max-age*
                (prrn "Cache-Control: max-age=" it))
              (prrn)
              (w/infile i it
                (whilet b (readb i)
                  (writeb b out))))
          (respond-err out "Unknown."))))))

(def handle-post (in out req)
  (iflet clen (req "content-length")
    (do (zap [errsafe:as int _] clen)
        (= req!args
           (+ req!args
              (let ctype (req "content-type")
                (if (~begins downcase.ctype "multipart/form-data")
                  (parseargs:string:readchars clen in) ; ascii
                  (parse-multipart-args multipart-boundary.ctype in))))) ; maybe non-ascii
        (respond out req))
    (respond-err out "Post request without Content-Length.")))

(def multipart-boundary (s)
  (let delim "boundary="
    (+ "--" (cut s (+ (findsubseq delim s)
                      len.delim)))))

(def parse-multipart-args (boundary in)
  (scan-past boundary in) ; skip prelude
  (accum yield
    (until (multipart-end boundary in)
      (withs (headers   scan-headers.in
              body  (scan-body boundary in)) ; only part that may contain non-ascii
        (when headers
          (yield:parse-multipart-part headers body))))))

; "The final boundary is followed by two more hyphens to indicate that no
; further parts follow."
;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
; We've already read the boundary itself.
(def multipart-end (boundary in)
  (aif peekc.in
    (and (is #\- it) readc.in
         (or (is #\- peekc.in)
             ; "one #\- shalt thou not count,
             ; excepting that thou then proceed to two"
             (ero "malformed multipart input; boundary followed by just one '-'. Is it the final part or isn't it?")))
    (ero "malformed multipart input; request didn't have a final boundary")))

(def scan-headers (in)
  ; "The boundary must be followed immediately either by another CRLF and the
  ; header fields for the next part, or by two CRLFs, in which case there are no
  ; header fields for the next part.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (parse-mime-header:bytes-string:scan-past "\r\n\r\n" in))

(def scan-body (boundary in)
  ; "The CRLF preceding the encapsulation line is considered part of the
  ; boundary.."
  ;   -- http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
  (scan-past (+ "\r\n" boundary) in))

(def parse-multipart-part (headers body)
  (awhen (and headers (alref headers "name"))
    (list unstring.it
          (w/table multipart-arg
            (= (multipart-arg "contents")
               (if (all-ascii? body)
                 bytes-string.body
                 body))
            (each (property val) headers
              (unless (iso "name" property)
                (= multipart-arg.property val)))))))

; parse lines of the form a=b; c=d; e=f; ..
; segments without '=' are passed through as single-elem lists
(def parse-mime-header (line)
  (map [tokens _ #\=]
       (tokens downcase.line (orf whitec (testify #\;)))))

; return list of bytes until pat is encountered
; pat is read from input but dropped from result
; all chars in pat must be 1-byte
(def scan-past (pat in)
  (= pat (map int (coerce pat 'cons)))
  (let buffer (spliceable-list len.pat)
    (until (iso pat suffix.buffer)
      (append buffer (list readb.in)))
    splice.buffer))

; convert list of bytes to string
(def bytes-string (l)
  (coerce (map [coerce _ 'char]
               l)
          'string))

(def all-ascii? (l)
  (errsafe:all [<= 0 _ 127] l))

; "\"abc\"" => "abc"
(def unstring (s)
  (if (iso #\" s.0)
    (cut s 1 -1)
    s))

(def respond-err (str msg . args)
  (w/stdout str
    (prrn "HTTP/1.1 404 Not Found")
    (prrn "Content-Type: text/html; charset=utf-8")
    (prrn "Connection: close")
    (prrn)
    (apply pr msg args)))

(def parse-header ((o in (stdin)))
  (let (request-line . header-lines) read-header.in
    (as table (accum yield
      (map yield parse-cmd.request-line)
      (map yield (map split-header header-lines))))))

(def read-header ((o in (stdin)))
  (with (nls 0  lines nil  line nil)
    (forever:let c readc.in
      (if no.c (break))
      (if (is c #\return) (continue))
      (if (is c #\newline)
        (++ nls)
        (= nls 0))
      (when (>= nls 2)
        (break))
      (if (is c #\newline)
        (do (push (string rev.line) lines)
            (wipe line))
        (push c line)))
    rev.lines))

(def split-header (line)
  (whenlet n (findsubseq ": " line)
    (list (downcase:cut line 0 n)  ; normalize header key
          (cut line (+ n 2)))))

(def parse-cmd (request-line)
  (accum yield
    (let (type url) tokens.request-line
      (yield `(type ,(sym downcase.type)))
      (let (base args) (tokens url #\?)
        (yield `(op ,(sym:cut base 1)))  ; skip leading slash
        (aif args
          (yield `(args ,parseargs.it)))))))

; 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 parse-cookies (s)
  (map [tokens _ #\=]
       (tokens s [or whitec._ (is _ #\;)])))

(def arg (req key)
  (acheck (alref req!args key) [~isa _ 'table]
    ; deref multipart params by default
    (it "contents")))

(def multipart-metadata (req arg key)
  (let val (alref req!args arg)
    (if (isa val 'table)
      val.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 10)) ~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) (prrn) (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")

(= dead-msg* "\nUnknown or expired link.")

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

(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) (prrn) (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)
                           (prrn)
                           (,f ,ga))))
       ,@body)))

(mac aform-multi (f . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action (string fnurl* "?fnid="
                               (fnid (fn (,ga)
                                       (prrn)
                                       (,f ,ga)))))
       ,@body)))

(mac form-multi (action . body)
  (w/uniq ga
    `(tag (form method 'post
                enctype "multipart/form-data"
                action ,action)
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prrn) (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) (prrn) (,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 8))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
      (unique-id)
      (= (unique-ids* id) id))))

(def srvlog (type . args)
  (ontofile (logfile-name type)
            (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)))

)

(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*)))

; 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.


hl2b: imported 'it, 'some

hl2b: imported 'it, 'some

; front end to the bytecode compiler
; loads all the files and defines an entry function

; define the <hl> package and import functions and macros needed
; by the compiler from <arc>v3
; TODO: move in a file conditionally loaded only when bootstrapping
;       using hl-arc-f
(in-package hl)
(using <arc>v3)
; Should really use <hl>def, not just def, because def in this
; context will be <arc>def.  Same with <hl>type etc.
; Please see http://hl.webhop.net/item?id=103 ; I recommended
; using 3 sections, and specified which ones should specify
; specific packages, and which ones just use <arc> packages.
(interface v0 def mac if and no or each load string unpkg prn = w/infile
              let with withs fn afn require w/uniq coerce + push listtab
              givens make-br-fn ++ acons ssyntax isnt caris _ in type isa
              alist err is car cons cdr map orf awhen do trav+ when ontable
              list aif zap self makeproper rfn pos complement dotted len on
              index copy mappend cadr cddr len> it some
              ; types
              int char table string sym)

(set <hl>unpkg <arc>unpkg)
(set <hl>ssyntax <arc>ssyntax)
(set <hl>pos <arc>pos)

; the compiler package
(in-package compiler)
(using <hl>v0)

(interface v0 compile)

; strictly, "compiled-and-executed-files"
(set files* '("structs.hl" "bytecodegen.hl"
              "quote-lift.hl" "utils.hl" "closures.hl" "cps.hl"
              "sharedvars.hl"  "xe.hl"))
; need also *another* set of files for "compiled-only-but-not-executed-files"

; load all the files
(each f files*
  (load f))

; entry point
; return a 0 arg function that executes expr
;(def compile (expr)
;  (<axiom>assemble (compile-to-bytecode expr)))
; above doesn't actually make sense from within
; Arc-F, because Arc-F doesn't support <axiom>assemble.
; Maybe should be in the "compiled-but-not-executed"
; set of files

; front end to the bytecode compiler
; loads all the files and defines an entry function

; define the <hl> package and import functions and macros needed
; by the compiler from <arc>v3
; TODO: move in a file conditionally loaded only when bootstrapping
;       using hl-arc-f
(in-package hl)
(using <arc>v3)
; Should really use <hl>def, not just def, because def in this
; context will be <arc>def.  Same with <hl>type etc.
; Please see http://hl.webhop.net/item?id=103 ; I recommended
; using 3 sections, and specified which ones should specify
; specific packages, and which ones just use <arc> packages.
(interface v0 def mac if and no or each load string unpkg prn = w/infile
              let with withs fn afn require w/uniq coerce + push listtab
              givens make-br-fn ++ acons ssyntax isnt caris _ in type isa
              alist err is car cons cdr map orf awhen do trav+ when ontable
              list aif zap self makeproper rfn pos complement dotted len on
              index copy mappend cadr cddr len>
              ; types
              int char table string sym)

(set <hl>unpkg <arc>unpkg)
(set <hl>ssyntax <arc>ssyntax)
(set <hl>pos <arc>pos)

; the compiler package
(in-package compiler)
(using <hl>v0)

(interface v0 compile)

; strictly, "compiled-and-executed-files"
(set files* '("structs.hl" "bytecodegen.hl"
              "quote-lift.hl" "utils.hl" "closures.hl" "cps.hl"
              "sharedvars.hl"  "xe.hl"))
; need also *another* set of files for "compiled-only-but-not-executed-files"

; load all the files
(each f files*
  (load f))

; entry point
; return a 0 arg function that executes expr
;(def compile (expr)
;  (<axiom>assemble (compile-to-bytecode expr)))
; above doesn't actually make sense from within
; Arc-F, because Arc-F doesn't support <axiom>assemble.
; Maybe should be in the "compiled-but-not-executed"
; set of files


implicit by aw

implicit by aw

; 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))

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

; 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 classify (classifier seq)
  " Groups the elements of `seq' by `classifier', returning back a table,
    whose keys are the results of `classifier' and whose values are lists
    of the corresponding elements of `seq'. For example:

      arc> (classify type '(1 \"foo\" a 2 (b)))
      #hash((cons . ((b))) (int . (2 1)) (string . (\"foo\")) (sym . (a)))

    See also [[partition]] [[keep]] [[rem]] "
  (w/table h
    (each e seq
      (push e (h classifier.e)))))

(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 unzip (xs)
  " Precisely as `zip', except that zip's `ls' is unzip's `xs'; so it takes one
    list of lists rather than any number of lists as arguments. Can be thought
    of as performing the inverse operation.
    See also [[zip]] "
  (apply map list xs))

(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.
    See also [[unzip]] "
  (unzip ls))

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

; 'many was precisely the same function as 'acons, hence has been removed (any
; cons has a length > 0, since nil is not a cons). Also, 'popfind has been
; renamed 'pull1, to fit with the newly-added 'rem1.

(def rem1 (test seq)
  " Returns a copy of `seq' with the first element that passes `test' removed.
    See also [[rem]] [[keep]] [[pull1]] [[pull]] "
  (zap testify test)
  (if alist.seq ((afn (s)
                   (if no.s nil
                       (f car.s) cdr.s
                       (cons car.s (self cdr.s))))
                 seq)
      (coerce (rem1 test (coerce seq 'cons)) 'string)))

(mac pull1 (test place)
  " Removes the first element that passes `test' from `place'.
    See also [[pull]] [[rem1]] [[rem]] [[keep]] "
  `(= ,place (rem1 ,test ,place)))

(def butlast (x)
  " Returns a list containing every element of `x' but the last.
    See also: [[cut]] "
  (cut x 0 (- (len x) 1)))

(= len= [is len._a _b])
(= len- [- len._a _b])
(= car< [< car._a car._b])
(= cdar cdr:car)
(= cadar car:cdar)
(= mapcar [map car _])
(= mapcdr [map cdr _])

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

(def rand-pos (lst) (if lst (rand:len lst)))

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

(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)))))

; 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]] [[where]] "
  `(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]] [[where]] [[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))

; inspired by Haskell
(mac where (expr . parms)
  " Binds `parms' and evaluates `expr'. Examples:

      arc> (where (square x)
              square [* _ _]
              x 2)
      4

    Note that binding is recursive, but that actual assignment of values is done
    in the reverse of the order given, so any variables which are both bound and
    used in `parms' must be used in reverse dependency order:

      arc> (where x x (+ y y) y 0)    ; this works as expected
      y
      arc> (where x y 0 x (+ y y))    ; this doesn't
      nil

    Essentially, this is a reversed form of Scheme's 'letrec,
    with many fewer parentheses. Inspired by Haskell's \"where\".
    See also [[withr]] [[withr/p]] [[withf]] "
  `(withr/p ,(rev:pair parms) ,expr))

; 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))

; ripoff: between, by Andrew Wilcox
; http://awwx.ws/between
; CHANGED 2010-01-02:
;   + added docstrings - Michael Arntzenius
;   + only wipe first on the first run through
;  - Michael Arntzenius

(mac between (var expr within . body)
  " As 'each, but runs `within' between each iteration of `body'.
    See also [[each]] "
  (w/uniq first
    `(let ,first t
       (each ,var ,expr
         (unless ,first
           ,within
           (wipe ,first))
         ,@body))))

; Andrew Wilcox henceforth aw

; xloop by aw
(mac xloop (withses . body)
  (let w (pair withses)
      `((rfn next ,(map car w) ,@body) ,@(map cadr w))))

; http://awwx.ws/implicit2.arc
(mac implicit (name (o val))
  `(do (defvar ,name ($.make-parameter ,val))
       (mac ,(sym (string "w/" name)) (v . body)
         (w/uniq (param gv gf)
           `(with (,param (defvar-impl ,',name)
                   ,gv ,v
                   ,gf (fn () ,@body))
              ($ (parameterize ((,param ,gv)) (,gf))))))))

; ripoff: ret, by skenney26
; http://github.com/skenney26/kwizwiz/blob/master/kwizwiz.arc

(mac ret (var val . body)
  `(let ,var ,val ,@body ,var))

; END RIPOFFS

; 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))

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

; 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 classify (classifier seq)
  " Groups the elements of `seq' by `classifier', returning back a table,
    whose keys are the results of `classifier' and whose values are lists
    of the corresponding elements of `seq'. For example:

      arc> (classify type '(1 \"foo\" a 2 (b)))
      #hash((cons . ((b))) (int . (2 1)) (string . (\"foo\")) (sym . (a)))

    See also [[partition]] [[keep]] [[rem]] "
  (w/table h
    (each e seq
      (push e (h classifier.e)))))

(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 unzip (xs)
  " Precisely as `zip', except that zip's `ls' is unzip's `xs'; so it takes one
    list of lists rather than any number of lists as arguments. Can be thought
    of as performing the inverse operation.
    See also [[zip]] "
  (apply map list xs))

(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.
    See also [[unzip]] "
  (unzip ls))

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

; 'many was precisely the same function as 'acons, hence has been removed (any
; cons has a length > 0, since nil is not a cons). Also, 'popfind has been
; renamed 'pull1, to fit with the newly-added 'rem1.

(def rem1 (test seq)
  " Returns a copy of `seq' with the first element that passes `test' removed.
    See also [[rem]] [[keep]] [[pull1]] [[pull]] "
  (zap testify test)
  (if alist.seq ((afn (s)
                   (if no.s nil
                       (f car.s) cdr.s
                       (cons car.s (self cdr.s))))
                 seq)
      (coerce (rem1 test (coerce seq 'cons)) 'string)))

(mac pull1 (test place)
  " Removes the first element that passes `test' from `place'.
    See also [[pull]] [[rem1]] [[rem]] [[keep]] "
  `(= ,place (rem1 ,test ,place)))

(def butlast (x)
  " Returns a list containing every element of `x' but the last.
    See also: [[cut]] "
  (cut x 0 (- (len x) 1)))

(= len= [is len._a _b])
(= len- [- len._a _b])
(= car< [< car._a car._b])
(= cdar cdr:car)
(= cadar car:cdar)
(= mapcar [map car _])
(= mapcdr [map cdr _])

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

(def rand-pos (lst) (if lst (rand:len lst)))

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

(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)))))

; 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]] [[where]] "
  `(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]] [[where]] [[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))

; inspired by Haskell
(mac where (expr . parms)
  " Binds `parms' and evaluates `expr'. Examples:

      arc> (where (square x)
              square [* _ _]
              x 2)
      4

    Note that binding is recursive, but that actual assignment of values is done
    in the reverse of the order given, so any variables which are both bound and
    used in `parms' must be used in reverse dependency order:

      arc> (where x x (+ y y) y 0)    ; this works as expected
      y
      arc> (where x y 0 x (+ y y))    ; this doesn't
      nil

    Essentially, this is a reversed form of Scheme's 'letrec,
    with many fewer parentheses. Inspired by Haskell's \"where\".
    See also [[withr]] [[withr/p]] [[withf]] "
  `(withr/p ,(rev:pair parms) ,expr))

; 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))

; ripoff: between, by Andrew Wilcox
; http://awwx.ws/between
; CHANGED 2010-01-02:
;   + added docstrings - Michael Arntzenius
;   + only wipe first on the first run through
;  - Michael Arntzenius

(mac between (var expr within . body)
  " As 'each, but runs `within' between each iteration of `body'.
    See also [[each]] "
  (w/uniq first
    `(let ,first t
       (each ,var ,expr
         (unless ,first
           ,within
           (wipe ,first))
         ,@body))))

; Andrew Wilcox henceforth aw

; xloop by aw
(mac xloop (withses . body)
  (let w (pair withses)
      `((rfn next ,(map car w) ,@body) ,@(map cadr w))))

; ripoff: ret, by skenney26
; http://github.com/skenney26/kwizwiz/blob/master/kwizwiz.arc

(mac ret (var val . body)
  `(let ,var ,val ,@body ,var))

; END RIPOFFS