add setter for vectors (vector index referencing was accidentally pushed in last commit - thanks to rocketnia for telling me about defcall)

(require "lib/util.arc")
(require "lib/math.arc")
(require "lib/extend.arc")

; statistics. 06 Oct 2010.

; Ali Moeeny

(def diffSquared (x y)
     		 (apply + (map [* (- _ y)(- _ y)] x)))

(def sumSquared (x y)
     	   (apply + (map * x y)))

(def sumDiffMultiplied (x y)
       (with (mx (avg x) my (avg y))
       (reduce +
       	       (map *
	       	    (map [- _ mx] x)
		    (map [- _ my] y)))))

(def pearsonsCorrelation (x y)
     (/ (sumDiffMultiplied x y)
        (sqrt
	      (*
	      	 (diffSquared
		 	 x
			 (avg x))
	         (diffSquared y
		 	 (avg y)))))
)

; Mark Huetsch

; Some simple matrix stuff I wrote. Would probably be better if matrix were its own type, like a hash table, so that things like + and - could
; be used in lieu of +m and -m, and ij could be eliminated, but this was just thrown together when I needed a nearest neighbors alg.

(def pm (m)
  (each r m (prn r)))

(def +v vs
  (map [reduce + _] (apply zip vs)))

(def -v vs
  (map [reduce - _] (apply zip vs)))

(def *v (a b)
  (if (isa a 'int)
      (map [* a _] b)
      (map [* b _] a)))

(def lenv (v)
  (sqrt (reduce + (map square v))))

(def dot (a b)
  (reduce + (map [apply * _] (zip a b))))

(def cosv (a b)
  (/ (dot a b) (* (lenv a) (lenv b))))

(def cosm (m)
  (mapeach row1 m
	   (map [cosv _ row1] m)))

(def pearson (x y)
  (with (xbar (avg x) ybar (avg y))
    (/ (reduce + (map (fn (xi yi) (* (- xi xbar) (- yi ybar))) x y))
       (sqrt (* (reduce + (map [square (- _ xbar)] x))
		(reduce + (map [square (- _ ybar)] y)))))))

(def pearsonm (m)
  (mapeach row1 m
	   (map [pearson _ row1] m)))

(def rows (m) m)

(def cols (m)
  (apply zip m))

(def tm (m)
  (cols m))

(def +m ms
  (map [apply +v _] (apply zip ms)))

(def -m ms
  (map [apply -v _] (apply zip ms)))

(def ij (m i j)
  ((m i) j))

(mac sij (m i j v)
  (w/uniq modified-row
    `(= ,m
	(let ,modified-row (,m ,i)
	  (+ (cut ,m 0 ,i)
	     (list (+ (cut ,modified-row 0 ,j) (list ,v) (cut ,modified-row (+ 1 ,j))))
	     (cut ,m (+ 1 ,i)))))))

(def bestnpos (n f seq)
  (with (vals (bestn n f seq) indices nil last-val nil last-pos 0)
    (each val vals
      (let found-pos (pos val seq (if (is val last-val) (+ 1 last-pos) 0))
	(push found-pos indices)
	(= last-val val)
	(= last-pos found-pos)))
    (rev indices)))

(def weighted-nearest-neighbors (v m (o n 10))
  (let pearm (pearsonm (+ m (list v)))
    (mapeach vec-pos (bestnpos n > (butlast (last pearm)))
	     (list (m vec-pos) ((butlast (last pearm)) vec-pos)))))

; maybe base this off of a weighted-nearest-neighbors? and allow to choose similarity function
(def nearest-neighbors (v m (o n 10))
  (let pearm (pearsonm (+ m (list v)))
    (mapeach vec-pos (bestnpos n > (butlast (last pearm)))
	     (m vec-pos))))

(def vec lst
  (annotate 'vector lst))

(extend + args (all [isa _ 'vector] args)
        (apply +v (map rep args)))

(extend - args (all [isa _ 'vector] args)
        (apply -v (map rep args)))

 (defcall vector (vec i)
    rep.vec.i)

; This manner of setting inspired by lush. I like it because it saves a lot of typing if you're constantly modifying vectors.
 (defcall vector (vec i val)
    (= rep.vec.i val))


job #10276 added extra check for string types when generating 'any where' clauses

.//============================================================================
.// This archetype file contains functions for generating optimized object
.// instance selection services.
.//============================================================================
.//
.//============================================================================
.// Generate a routine that encapsulates the scanning of a set for a
.// specific instance.  The contents of this routine could be changed
.// to optimize for speed this type of selection.  As it stands here,
.// the optimization is more for space.
.//============================================================================
.function AddObjectExtentSelectAnyWhereMethod
  .param inst_ref o_obj
  .param inst_ref o_oid
  .param boolean  gen_declaration
  .//
  .select any te_extent from instances of TE_EXTENT
  .select any te_file from instances of TE_FILE
  .select any te_instance from instances of TE_INSTANCE
  .select any te_set from instances of TE_SET
  .select any te_string from instances of TE_STRING
  .select one te_class related by o_obj->TE_CLASS[R2019]
  .select one te_where related by o_oid->TE_WHERE[R2032]
  .assign param_list = ""
  .assign compare_stmt = ""
  .assign cmp_element = ""
  .assign temp_ptr = "w"
  .//
  .select many te_attrs related by te_class->TE_ATTR[R2061]
  .for each te_attr in te_attrs
    .assign te_attr.Included = FALSE
  .end for
  .//
  .// Tag the indentifying attribute(s) that comprise this where clause.
  .select many ident_te_attrs related by o_oid->O_OIDA[R105]->O_ATTR[R105]->TE_ATTR[R2033]
  .assign num_ident_attr = cardinality ident_te_attrs
  .for each te_attr in ident_te_attrs
    .assign te_attr.Included = TRUE
    .assign te_attr.ParamBuffer = "w_${te_attr.Name}"
  .end for
  .//
  .select any te_attr related by te_class->TE_ATTR[R2061]
  .while ( not_empty te_attr )
    .select one prev_te_attr related by te_attr->TE_ATTR[R2087.'succeeds']
    .if ( empty prev_te_attr )
      .break while
    .end if
    .assign te_attr = prev_te_attr
  .end while
  .assign oida_count = 0
  .while ( not_empty te_attr )
    .if ( te_attr.Included )
      .assign oida_count = oida_count + 1
      .assign param_list = param_list + te_attr.GeneratedType
      .if ( not gen_declaration )
        .select one te_dt related by te_attr->O_ATTR[R2033]->S_DT[R114]->TE_DT[R2021]
        .select one base_te_dt related by te_attr->O_ATTR[R2033]->O_RATTR[R106]->O_BATTR[R113]->O_ATTR[R106]->S_DT[R114]->TE_DT[R2021]
        .if ( not_empty base_te_dt )
          .assign te_dt = base_te_dt
        .end if
        .if ( ( te_attr.dimensions == 0 ) and ( 4 != te_dt.Core_Typ ) )
          .assign cmp_element = "${temp_ptr}->${te_attr.GeneratedName} == ${te_attr.ParamBuffer}"
        .else
          .// "string"
          .assign cmp_element = "!${te_instance.module}${te_string.strcmp}(${temp_ptr}->${te_attr.GeneratedName}, ${te_attr.ParamBuffer})"
        .end if
        .//
        .assign param_list = param_list + " ${te_attr.ParamBuffer}"
        .assign compare_stmt = compare_stmt + cmp_element
      .end if
      .assign param_list = param_list + te_attr.array_spec
      .//
      .if ( oida_count < num_ident_attr )
        .assign param_list = param_list + ", "
        .assign compare_stmt = compare_stmt + " && "
      .end if
    .end if
    .select one te_attr related by te_attr->TE_ATTR[R2087.'precedes']
  .end while
  .//
  .if ( gen_declaration )
    .include "${te_file.arc_path}/t.class.select_where.h"
  .else
    .invoke r = GetFixedSizeClassExtentInfo( te_class )
    .assign extent = r.result
    .assign iterator = "iter_${te_class.Key_Lett}"
    .include "${te_file.arc_path}/t.class.select_where.c"
  .end if  .// gen_declaration
.end function
.//
.//============================================================================
.// Generate the list of where methods.
.//============================================================================
.function AddObjectSpecialWhereMethods
  .param inst_ref o_obj
  .param boolean  gen_declaration
  .//
  .select many te_wheres related by o_obj->O_ID[R104]->TE_WHERE[R2032] where ( selected.WhereKey )
  .if ( (not_empty te_wheres) and gen_declaration )

/*
 * Where clause instance selection against identifying attribute set(s).
 */
  .end if
  .//
  .for each te_where in te_wheres
    .select one o_oid related by te_where->O_ID[R2032]
    .invoke method = AddObjectExtentSelectAnyWhereMethod( o_obj, o_oid, gen_declaration )
${method.body}\
  .end for
.end function
.//

.//============================================================================
.// This archetype file contains functions for generating optimized object
.// instance selection services.
.//============================================================================
.//
.//============================================================================
.// Generate a routine that encapsulates the scanning of a set for a
.// specific instance.  The contents of this routine could be changed
.// to optimize for speed this type of selection.  As it stands here,
.// the optimization is more for space.
.//============================================================================
.function AddObjectExtentSelectAnyWhereMethod
  .param inst_ref o_obj
  .param inst_ref o_oid
  .param boolean  gen_declaration
  .//
  .select any te_extent from instances of TE_EXTENT
  .select any te_file from instances of TE_FILE
  .select any te_instance from instances of TE_INSTANCE
  .select any te_set from instances of TE_SET
  .select any te_string from instances of TE_STRING
  .select one te_class related by o_obj->TE_CLASS[R2019]
  .select one te_where related by o_oid->TE_WHERE[R2032]
  .assign param_list = ""
  .assign compare_stmt = ""
  .assign cmp_element = ""
  .assign temp_ptr = "w"
  .//
  .select many te_attrs related by te_class->TE_ATTR[R2061]
  .for each te_attr in te_attrs
    .assign te_attr.Included = FALSE
  .end for
  .//
  .// Tag the indentifying attribute(s) that comprise this where clause.
  .select many ident_te_attrs related by o_oid->O_OIDA[R105]->O_ATTR[R105]->TE_ATTR[R2033]
  .assign num_ident_attr = cardinality ident_te_attrs
  .for each te_attr in ident_te_attrs
    .assign te_attr.Included = TRUE
    .assign te_attr.ParamBuffer = "w_${te_attr.Name}"
  .end for
  .//
  .select any te_attr related by te_class->TE_ATTR[R2061]
  .while ( not_empty te_attr )
    .select one prev_te_attr related by te_attr->TE_ATTR[R2087.'succeeds']
    .if ( empty prev_te_attr )
      .break while
    .end if
    .assign te_attr = prev_te_attr
  .end while
  .assign oida_count = 0
  .while ( not_empty te_attr )
    .if ( te_attr.Included )
      .assign oida_count = oida_count + 1
      .assign param_list = param_list + te_attr.GeneratedType
      .if ( not gen_declaration )
        .if ( te_attr.dimensions == 0 )
          .assign cmp_element = "${temp_ptr}->${te_attr.GeneratedName} == ${te_attr.ParamBuffer}"
        .else
          .// "string"
          .assign cmp_element = "!${te_instance.module}${te_string.strcmp}(${temp_ptr}->${te_attr.GeneratedName}, ${te_attr.ParamBuffer})"
        .end if
        .//
        .assign param_list = param_list + " ${te_attr.ParamBuffer}"
        .assign compare_stmt = compare_stmt + cmp_element
      .end if
      .assign param_list = param_list + te_attr.array_spec
      .//
      .if ( oida_count < num_ident_attr )
        .assign param_list = param_list + ", "
        .assign compare_stmt = compare_stmt + " && "
      .end if
    .end if
    .select one te_attr related by te_attr->TE_ATTR[R2087.'precedes']
  .end while
  .//
  .if ( gen_declaration )
    .include "${te_file.arc_path}/t.class.select_where.h"
  .else
    .invoke r = GetFixedSizeClassExtentInfo( te_class )
    .assign extent = r.result
    .assign iterator = "iter_${te_class.Key_Lett}"
    .include "${te_file.arc_path}/t.class.select_where.c"
  .end if  .// gen_declaration
.end function
.//
.//============================================================================
.// Generate the list of where methods.
.//============================================================================
.function AddObjectSpecialWhereMethods
  .param inst_ref o_obj
  .param boolean  gen_declaration
  .//
  .select many te_wheres related by o_obj->O_ID[R104]->TE_WHERE[R2032] where ( selected.WhereKey )
  .if ( (not_empty te_wheres) and gen_declaration )

/*
 * Where clause instance selection against identifying attribute set(s).
 */
  .end if
  .//
  .for each te_where in te_wheres
    .select one o_oid related by te_where->O_ID[R2032]
    .invoke method = AddObjectExtentSelectAnyWhereMethod( o_obj, o_oid, gen_declaration )
${method.body}\
  .end for
.end function
.//


Eliminate readcs, which is unnecessary due to readchars and readbytes, and which also appeared buggy to me when I was parsing binary data in posts with file attachments due to the Content-Length being longer than the amount of chars available to be read. Presumably readc was slurping multiple bytes as single characters (what kind of encoding does mzscheme's read-char assume?), leading to the mismatch. Anyway, using readbytes fixes the problem.

;;; http.arc: dealing with the HTTP protocol

(deftem http-msg
  prot  nil     ; protocol  "HTTP/1.1"
  hds   nil)    ; headers   (("Content-Type" "html") ("Location" "/new"))

; A "request" is a message from the client to the server

(deftem (http-req http-msg)
  meth    nil    ; method [downcased sym]    get, post
  path	  nil    ; path                      "/some/thing"
  qs	  nil    ; query string              "foo=bar&baz=42"
  args	  nil    ; args of the qs/form post  (("foo" "bar") ("baz" "42"))
  cooks	  nil)   ; sent cookies	    	     (("sessid" "MTgY4h2"))

; A "response" is a message from the server to the client

(deftem (http-resp http-msg)
  sta	  nil    ; status code   404
  rea     nil)   ; reason        "Not Found"

(= http-ok+ 	    "200 OK"
   http-created+    "201 Created"
   http-found+	    "302 Found"
   http-notmod+	    "304 Not Modified"
   http-bad+	    "400 Bad Request"
   http-forbidden+  "403 Forbidden"
   http-notfound+   "404 Not Found")

(def read-headers ((o from (stdin)))
  (unless (is (peekc from) #\newline)  ; for suckers using \n instead of \r\n
    (let line (readline from)
      (awhen (pos #\: line)
        (cons (list (normalize-hdname:cut line 0 it)
                    (trim:cut line (+ it 1)))
              (read-headers from))))))

(def normalize-hdname (name)  ; "content-type" -> "Content-Type"
  (string:intersperse #\- (map capitalize (tokens name #\-))))

(def capitalize (word)  ; "foobar" -> "Foobar"
  (+ (upcase word.0) (cut word 1)))

(def read-req ((o from (stdin)))
  (withs ((m pa pro) (read-reqline from)
  	  (rpa qs)   (tokens pa #\?)
	  hds        (read-headers from))
    (inst 'http-req  'prot pro  'meth (sym:downcase m)
    	  	     'path rpa  'qs qs   'hds hds
		     'cooks (parse-cooks hds)
		     'args (only.parse-args qs))))

(def read-reqline ((o from (stdin)))  (tokens:readline from))

(def parse-args (argstr)  ; "foo=bar&baz=42" -> (("foo" "bar") ("baz" "42"))
  (map [map urldecode (tokens _ #\=)] (tokens argstr #\&)))

(def parse-cooks (reqhds)
  (reduce join
    (map [map [tokens (trim _) #\=] (tokens _.1 #\;)]
    	 (keep [caris _ "Cookie"] reqhds))))

(def read-resp ((o from (stdin)))
  (let (pro st . reas) (tokens (readline from))
    (inst 'http-resp 'prot pro  'sta (int st)
	    	     'rea (string:intersperse " " reas)
		     'hds (read-headers from))))

(def pr-headers (hds)
  (each (n v) hds  (prrn n ": " v))
  (prrn))

(def prrn args  ; print with \r\n at the end
  (map1 disp args)
  (prn #\return))

; we call "head" the top part of an HTTP message,
; i.e: the status or request line plus the headers

(def reqhead (meth path hds)
  (prrn upcase.meth " " path " HTTP/1.0")
  ; 1.0 because a 1.1 client should be able to deal with
  ; "Transfert-Encoding: chunked" (and we don't, at least yet)
  (pr-headers hds))

(def resphead ((o sta http-ok+) (o hds httpd-hds*))
  (prrn "HTTP/1.1 " sta)
  (pr-headers hds))

(def redirect (loc (o sta http-found+) (o hds httpd-hds*))
  (resphead sta (copy hds 'Location loc)))

;; httpd: generic HTTP server.
; put it behind a reverse proxy, and code your own "framework".
; doesn't deal with logging, gzipping, slow and bad clients,
; keep-alive, limits of req/<time>: nginx can do it for us

(= httpd-hds*    (obj Server        "http.arc"
   		      Content-Type  "text/html"  ; set encoding in your HTML
		      Connection    "closed")
   stop-httpd*	  nil
   httpd-handler  nil)  ; ** the function your web app has to define **

(def httpd-serve ((o port 8080))
  (w/socket s port
    (until stop-httpd*
      (let (in out ip) (socket-accept s)
        (thread:handle-req in out ip)))))

(def handle-req (in out ip)
  (after
    (let req (read-req in)
      (= req!ip ip)  ; TODO: check and use X-Real-IP
      (read-body req in)
      (w/stdout out (httpd-handler req)))
    (close in out)))

(def read-body (req (o from (stdin)))
  (awhen (aand (alref req!hds "Content-Length") (errsafe:int it))
    (= req!body (readbytes it from))
    (when (findsubseq "x-www-form-urlencoded" (alref req!hds "Content-Type"))
      (= req!args (join req!args (parse-args:string (map [coerce _ 'char] req!body)))))))

(def start-httpd ((o port 8080))
  (wipe stop-httpd*)
  (prn "httpd: serving on port " port)
  (thread:httpd-serve port))

;; Very basic HTTP client.  still a work in progress: incomplete/ugly
;
; /!\ To have the code below working, you need to patch Arc to get
; client sockets.  here the function is called 'client-socket

(def parse-url (url)
  (with (prot "http"  host nil 	port 80	 path "/")
    (awhen (findsubseq "://" url)  ; explicit protocol?
      (= prot (downcase:cut url 0 it)
      	 url (cut url (+ it 3))))
    (aif (pos #\/ url)  ; deal with host & path
    	 (= host (cut url 0 it)
	    path (cut url it))
	 (= host url))
    (awhen (pos #\: host)  ; explicit port?
      (= port (int (cut host inc.it))
      	 host (cut host 0 it)))
    (list prot host port path)))

(def mk-http-req (method host path (o hds) (o port 80) (o body))
  (let (in out) (client-socket host port)
    (w/stdout out
      (reqhead (upcase method) path hds)
      (prt body)
      (flushout))
    (after (list (read-resp in) in)
           (close out))))

(def http-get (url)  ; consume the headers and return the output stream
  (let (prot host port path) (parse-url url)
    (cadr (mk-http-req 'GET host path (obj Host host
	   			           Connection "close") port))))

; hard drives crash, files get lost, cool URLs don't die

(let _infile infile
  (def infile (url)
    (if (begins (downcase url) "http://")
    	(http-get url)
	(_infile url)))
)

; arc> (filechars "http://www.faqs.org/rfcs/rfc2616.html")
; arc> (load "http://hacks.catdancer.ws/json.arc")

;; todo:
; * http-ok+ & co: remove the "+"? "*"?
;   not sure about "httpd" too.  at least rename 'httpd-serve to 'serve-http?
;
; * handle file uploads
;
; * deal with user@pwd in 'parse-url
;
; * actually wrong to use a table for httpd-hds*: it's legal to use the
; same header twice.  normally should be not break to change to an assoc
; list ('pr-headers would still work).  should make it.
;
; * maybe make it event-based or rewrite Arc to have a sane, really
; lightweight threading facility à la Erlang

;;; http.arc: dealing with the HTTP protocol

(deftem http-msg
  prot  nil     ; protocol  "HTTP/1.1"
  hds   nil)    ; headers   (("Content-Type" "html") ("Location" "/new"))

; A "request" is a message from the client to the server

(deftem (http-req http-msg)
  meth    nil    ; method [downcased sym]    get, post
  path	  nil    ; path                      "/some/thing"
  qs	  nil    ; query string              "foo=bar&baz=42"
  args	  nil    ; args of the qs/form post  (("foo" "bar") ("baz" "42"))
  cooks	  nil)   ; sent cookies	    	     (("sessid" "MTgY4h2"))

; A "response" is a message from the server to the client

(deftem (http-resp http-msg)
  sta	  nil    ; status code   404
  rea     nil)   ; reason        "Not Found"

(= http-ok+ 	    "200 OK"
   http-created+    "201 Created"
   http-found+	    "302 Found"
   http-notmod+	    "304 Not Modified"
   http-bad+	    "400 Bad Request"
   http-forbidden+  "403 Forbidden"
   http-notfound+   "404 Not Found")

(def read-headers ((o from (stdin)))
  (unless (is (peekc from) #\newline)  ; for suckers using \n instead of \r\n
    (let line (readline from)
      (awhen (pos #\: line)
        (cons (list (normalize-hdname:cut line 0 it)
                    (trim:cut line (+ it 1)))
              (read-headers from))))))

(def normalize-hdname (name)  ; "content-type" -> "Content-Type"
  (string:intersperse #\- (map capitalize (tokens name #\-))))

(def capitalize (word)  ; "foobar" -> "Foobar"
  (+ (upcase word.0) (cut word 1)))

(def read-req ((o from (stdin)))
  (withs ((m pa pro) (read-reqline from)
  	  (rpa qs)   (tokens pa #\?)
	  hds        (read-headers from))
    (inst 'http-req  'prot pro  'meth (sym:downcase m)
    	  	     'path rpa  'qs qs   'hds hds
		     'cooks (parse-cooks hds)
		     'args (only.parse-args qs))))

(def read-reqline ((o from (stdin)))  (tokens:readline from))

(def parse-args (argstr)  ; "foo=bar&baz=42" -> (("foo" "bar") ("baz" "42"))
  (map [map urldecode (tokens _ #\=)] (tokens argstr #\&)))

(def parse-cooks (reqhds)
  (reduce join
    (map [map [tokens (trim _) #\=] (tokens _.1 #\;)]
    	 (keep [caris _ "Cookie"] reqhds))))

(def read-resp ((o from (stdin)))
  (let (pro st . reas) (tokens (readline from))
    (inst 'http-resp 'prot pro  'sta (int st)
	    	     'rea (string:intersperse " " reas)
		     'hds (read-headers from))))

(def pr-headers (hds)
  (each (n v) hds  (prrn n ": " v))
  (prrn))

(def prrn args  ; print with \r\n at the end
  (map1 disp args)
  (prn #\return))

; we call "head" the top part of an HTTP message,
; i.e: the status or request line plus the headers

(def reqhead (meth path hds)
  (prrn upcase.meth " " path " HTTP/1.0")
  ; 1.0 because a 1.1 client should be able to deal with
  ; "Transfert-Encoding: chunked" (and we don't, at least yet)
  (pr-headers hds))

(def resphead ((o sta http-ok+) (o hds httpd-hds*))
  (prrn "HTTP/1.1 " sta)
  (pr-headers hds))

(def redirect (loc (o sta http-found+) (o hds httpd-hds*))
  (resphead sta (copy hds 'Location loc)))

;; httpd: generic HTTP server.
; put it behind a reverse proxy, and code your own "framework".
; doesn't deal with logging, gzipping, slow and bad clients,
; keep-alive, limits of req/<time>: nginx can do it for us

(= httpd-hds*    (obj Server        "http.arc"
   		      Content-Type  "text/html"  ; set encoding in your HTML
		      Connection    "closed")
   stop-httpd*	  nil
   httpd-handler  nil)  ; ** the function your web app has to define **

(def httpd-serve ((o port 8080))
  (w/socket s port
    (until stop-httpd*
      (let (in out ip) (socket-accept s)
        (thread:handle-req in out ip)))))

(def handle-req (in out ip)
  (after
    (let req (read-req in)
      (= req!ip ip)  ; TODO: check and use X-Real-IP
      (read-body req in)
      (w/stdout out (httpd-handler req)))
    (close in out)))

(def read-body (req (o from (stdin)))
  (awhen (aand (alref req!hds "Content-Length") (errsafe:int it))
    (= req!body (readcs it from))
    (when (findsubseq "x-www-form-urlencoded" (alref req!hds "Content-Type"))
      (= req!args (join req!args (parse-args:string req!body))))))

(def readcs (n (o from (stdin)))  ; read n characters
  (when (positive n)
    (cons (readc from) (readcs (- n 1) from))))

(def start-httpd ((o port 8080))
  (wipe stop-httpd*)
  (prn "httpd: serving on port " port)
  (thread:httpd-serve port))

;; Very basic HTTP client.  still a work in progress: incomplete/ugly
;
; /!\ To have the code below working, you need to patch Arc to get
; client sockets.  here the function is called 'client-socket

(def parse-url (url)
  (with (prot "http"  host nil 	port 80	 path "/")
    (awhen (findsubseq "://" url)  ; explicit protocol?
      (= prot (downcase:cut url 0 it)
      	 url (cut url (+ it 3))))
    (aif (pos #\/ url)  ; deal with host & path
    	 (= host (cut url 0 it)
	    path (cut url it))
	 (= host url))
    (awhen (pos #\: host)  ; explicit port?
      (= port (int (cut host inc.it))
      	 host (cut host 0 it)))
    (list prot host port path)))

(def mk-http-req (method host path (o hds) (o port 80) (o body))
  (let (in out) (client-socket host port)
    (w/stdout out
      (reqhead (upcase method) path hds)
      (prt body)
      (flushout))
    (after (list (read-resp in) in)
           (close out))))

(def http-get (url)  ; consume the headers and return the output stream
  (let (prot host port path) (parse-url url)
    (cadr (mk-http-req 'GET host path (obj Host host
	   			           Connection "close") port))))

; hard drives crash, files get lost, cool URLs don't die

(let _infile infile
  (def infile (url)
    (if (begins (downcase url) "http://")
    	(http-get url)
	(_infile url)))
)

; arc> (filechars "http://www.faqs.org/rfcs/rfc2616.html")
; arc> (load "http://hacks.catdancer.ws/json.arc")

;; todo:
; * http-ok+ & co: remove the "+"? "*"?
;   not sure about "httpd" too.  at least rename 'httpd-serve to 'serve-http?
;
; * handle file uploads
;
; * deal with user@pwd in 'parse-url
;
; * actually wrong to use a table for httpd-hds*: it's legal to use the
; same header twice.  normally should be not break to change to an assoc
; list ('pr-headers would still work).  should make it.
;
; * maybe make it event-based or rewrite Arc to have a sane, really
; lightweight threading facility à la Erlang