Package: src/packages/web.fdoc

Http Server Support

key file
__init__.flx share/lib/web/__init__.flx
web_util.flx share/lib/web/web_util.flx
http_auth.flx share/lib/web/http_auth.flx
http_request.flx share/lib/web/http_request.flx
http_response.flx share/lib/web/http_response.flx
http_handler.flx share/lib/web/http_handler.flx
http_connection.flx share/lib/web/http_connection.flx
http_status_code.flx share/lib/web/http_status_code.flx
mime_type.flx share/lib/web/mime_type.flx
cookie.flx share/lib/web/cookie.flx
low_res_time.flx share/lib/web/low_res_time.flx
json.flx share/lib/web/json.flx
sundown.flx share/lib/web/sundown.flx
logger.flx share/lib/web/logger.flx
simple_config.flx share/lib/web/simple_config.flx
server_config.flx share/lib/web/server_config.flx
web_server.flx share/lib/web/web_server.flx

Web Server Support Library

//[__init__.flx]
// codecs
include "web/json";
include "web/mime_type";

// http protocol handlers
include "web/web_util";
include "web/http_handler";
include "web/http_connection";
include "web/http_request";
include "web/http_status_code";
include "web/http_response";
include "web/http_auth";
include "web/cookie";
include "web/low_res_time";
include "web/server_config";
include "web/sundown";
include "web/logger";
include "web/simple_config";
//[web_util.flx]
class WebUtil {

  fun parse_attribute_list(lst:list[string]):list[string^2] =>
    map (fun (s:string) => match split_first(s,"=") with
                             |Some (i,j) => (strip i),(strip j)
                             |_       => "",""
                           endmatch ) lst;



}
//[http_auth.flx]
include "web/__init__";

publish """ Implements Basic HTTP Authentication
"""
class HTTPBasicAuth {
  open HTTPConnection;
  open HTTPRequest;
  open Assoc_list;
  open HTTPResponse;
  open Base64;
  open ServerConfig;
  open HTTPHandler;

  publish """
  A default app_handler for implementing Basic Auth. You must supply a function that
  takes a user name and password and returns fru or fals if authenticated. You must
  also supply a realm string which appears in the Authentication Prompt of the browser.
  This app_handler uses a route that applies to all pages
  """
  fun app_handlers(auth_source:(string*string->bool),realm:string) =>
    (Cons (http_handler(http_basic_auth_route,(http_basic_auth(auth_source,realm))),
     Empty[http_handler]));

  publish """
  A default route for http auth applies to all pages
  """
  fun http_basic_auth_route(config:server_config,request:http_request) =>
    true;

  private fun basic(s:string) =>ltrim s "Basic ";

  publish """
  Handler for http_basic_auth if Authorization header supplied by browser attemps to authenticate against auth source.
  If Authorization header not supplied send WWW-Authenticate header
  """



  gen http_basic_auth (auth_source:(string*string->bool),realm:string) (conn:http_connection, request:http_request) =  {
    http_basic_auth (auth_source,realm,"Unauthorized") (conn, request);
}

  gen http_basic_auth (auth_source:(string*string->bool),realm:string,unauth_content:string) (conn:http_connection, request:http_request) =  {
    if match (find (fun(x:string)=>x=="Authorization") request.headers) with
      |Some a => match split(decode(basic(a)),":") with
                      |Cons(n,Cons(p,Empty)) => auth_source(n,p)
                      |_ => false
                    endmatch
       |_       => false
      endmatch do
        set_dirty(conn,false);
        return ;
    else
      val hdrs:assoc_list[string,string] = Cons (("WWW-Authenticate","Basic realm=\""+realm+"\""), Empty[string*string]);
      var us = make_unauthorized(hdrs,unauth_content);
      write(conn,us);
    done
    set_dirty(conn,true);
    return ;
  }

publish """Authentication wrapper for a http_handler function, prcesses HTTP Authentication
and passes control to handler if Authentication succedes otherwise returns Unauthorized response
to the browser"""
  proc requires_auth (auth_source:(string*string->bool),realm:string,
                     handler_fn:(http_connection*http_request) -> void)
                    (conn:http_connection, request:http_request ) = {
    http_basic_auth (auth_source,realm) (conn, request);
    if not *conn.dirty do
      handler_fn(conn,request);
    done
  }

   proc requires_auth (auth_source:(string*string->bool),realm:string,
                     handler_fn:(http_connection*http_request) -> void,
                     unauthorized_content:string)
                    (conn:http_connection, request:http_request ) = {
    http_basic_auth (auth_source,realm,unauthorized_content) (conn, request);
    if not *conn.dirty do
      handler_fn(conn,request);
    done
  }




  gen authorized_user (conn:http_connection, request:http_request) =>
     match (find (fun(x:string)=>x=="Authorization") request.headers) with
      |Some a => match split(decode(basic(a)),":") with
                      |Cons(n,Cons(p,Empty)) => Some n
                      |_ => None[string]
                    endmatch
       |_       => None[string]
      endmatch ;


}
//[http_request.flx]
include "web/__init__";

publish """
Defines types and container for http_request.
Main entry points are get_param (helper to extract params from http_request)
and get_http_request which extracts request from stream
"""

class HTTPRequest {
   open HTTPConnection;
   open Assoc_list;
   open URICodec;
   open Logger;
   open Cookie;
   open IOStream;
   open Socket;
   open TerminalIOByteStream[socket_t];
   open WebUtil;

   variant http_method =
     | GET
     | POST
     | BAD;

  instance Str[http_method] {
    fun str : http_method ->string =
      | #GET => "GET"
      | #POST => "POST"
      | #BAD => "BAD";
   }

  instance Eq[http_method] {
    fun == : http_method*http_method->bool = "$1==$2";
    fun != : http_method*http_method->bool = "$1!=$2";
  }


   struct http_request {
    hmethod: http_method;
    uri: string;
    path:string;
    params:assoc_list[string,string];
    entity_params:assoc_list[string,string];
    headers:assoc_list[string,string];
  }

  instance Str[http_request] {
    fun str (request: http_request) =>
      "HTTP Request\n"+
      "\tMethod:"+str(request.hmethod)+"\n"+
      //"\tURI:"""+request.uri+"\n"+
      "\tPath:"""+request.path+"\n"+
      "\tParams:"""+str(request.params)+"\n"+
      "\tHeaders:"""+str(request.headers)+"\n";
  }

  private proc copy_request(orig:&http_request,cpy:&http_request) = {
    cpy.hmethod <- *orig.hmethod;
    cpy.uri <- *orig.uri;
    cpy.path <- *orig.path;
    cpy.params <- *orig.params;
  }

  publish """
  Parses a list of URI encoded key value parameters and returns as an assoc_list.
  """
  fun get_params(p:string):list[string*string] ={
     var params = split(p,'&');
     return   map  (fun(x:string):string*string =>let Cons(hd,tl) = split(x,'=') in
                     (uri_decode(hd),uri_decode((fold_left (fun(x:string) (y:string):string => x + y) "" tl)))
                     ) params;
  }

  noinline proc get_headers(conn:http_connection,headers:&list[string^2])  {
    var line:string = "";
    get_line(conn.sock, &line);  // shouldg be the GET line.
    while line != "" and line != "\r" do
      get_line(conn.sock, &line);
      match split(line,':') with
        | Cons(key,value) =>
              headers <- Cons((uri_decode(strip(key)),
            uri_decode(strip(fold_left (fun(x:string) (y:string):string => x + y) "" value))),
              *headers);
         | x => println("WARNING:Possible malformed request headerline:"+x);
      endmatch;
    done
  }

  publish """ Main entry point for extracting HTTP request from stream """
  noinline proc get_request(conn:http_connection,request:&http_request) = {
    var k = conn.sock;
    var line: string = "";
    get_line(k, &line);  // shouldg be the GET line.
    var got = match split(line,' ') with
      | Cons (hmethod,Cons(uri,Cons(prot,_))) => match (hmethod,uri,prot) with
        | ("GET",uri,prot)  => match (GET,uri,split(uri,'?'),prot) with
          | (GET,uri,Cons(path,rest),prot) =>
               http_request(GET,uri,path,
                get_params((fold_left (fun(x:string) (y:string):string => x + y) "" rest)),
                Empty[string*string],Empty[string*string])
            endmatch
        | ("POST",uri,prot)  => match (POST,uri,split(uri,'?'),prot) with
          | (POST,uri,Cons(path,rest),prot) => http_request(POST,uri,path,
                get_params((fold_left (fun(x:string) (y:string):string => x + y) "" rest)),
                Empty[string*string],Empty[string*string])
          endmatch
        endmatch
        | _ =>  http_request(BAD,"","",Empty[string*string],Empty[string*string],
                             Empty[string*string])
    endmatch;
    var headers = Empty[string^2];
    get_headers(conn,&headers);
    got&.headers <- headers;
    copy_request(&got,request);
    request.headers <- headers;
  }




  publish """
  Populates entity_params in request. Entity params are URI encoded key value pairs in
  request body that are supplied when a POST request is made by the browser.
  """
  proc get_entity_params(conn:http_connection,request:&http_request,attribs:list[string^2]) = {
    val olen = match get_header(*request,"Content-Length") with |Some s=> int(s) |_ => 0 endmatch;
    var len = olen;
    var eof=false;
    var params:assoc_list[string,string] = Empty[string*string];
    if olen > 0 do
      var buf = C_hack::cast[+char] (Memory::malloc(len+1));
      var buf_a = address(buf);
      read(conn.sock,&len,buf_a,&eof);
      if len > 0 do
        params = get_params(string(buf,len));
      done
      Memory::free(buf_a);
    done
    request.entity_params <- params;
    return ;
  }

fun read_bytes(conn:http_connection,olen:int) = {
    var len = olen;
    var eof=false;

    var ret:string = "";
    if olen > 0 do
      var buf = C_hack::cast[+char] (Memory::malloc(len+1));
      var buf_a = address(buf);
      read(conn.sock,&len,buf_a,&eof);
      ret= str(buf);
      Memory::free(buf_a);
     done
     return ret;
  }


  proc get_multipart_params(conn:http_connection,request:&http_request,attribs:list[string^2]) {
    var line:string = "";
    val llen = match get_header(*request,"Content-Length") with |Some s=> int(s) |_ => 0 endmatch;
    var rest = read_bytes(conn,llen);
    write(conn,HTTPResponse::make_continue());
    conn.dirty <- false;

    match (find (fun (s:string) => s == "boundary") attribs) with
      |Some b => { get_line(conn.sock, &line);
        var headers = Empty[string^2];
        get_headers(conn,&headers);
      }
     |_ => {conn.config.log(DEBUG,"No Boundry"); }
    endmatch;
     request.entity_params <- Empty[string*string];
  }

  fun get_fname(request:http_request) ={
    val v = match rev(split(request.path,'/')) with
      | Cons(hd,_) => Some(hd)
      | _ => None[string]
    endmatch;
    return v;
  }

  fun get_path_and_fname(request:http_request):opt[string^2] ={
    return match rev(split(request.path,'/')) with
      | Cons(hd,tl) => Some(
            (fold_left (fun(x:string) (y:string):string => x +"/"+ y) "" (rev(tl))), hd)
      | _ => None[string*string]
    endmatch;
  }

  publish """ Return opt[string] parameter value for given name """
  fun get_param(request:http_request,name:string) =>
     find (fun (a:string,b:string) => eq(a,b)) request.params name;

  publish """ Return opt[string] post parameter value for given name """
  fun get_post_param(request:http_request,name:string) =>
     find (fun (a:string,b:string) => eq(a,b)) request.entity_params name;

  publish """ Return opt[string] request header value for given name """
  fun get_header(request:http_request,name:string) =>
     find (fun (a:string,b:string) => eq(a,b)) request.headers name;

  fun get_cookies(request:http_request):list[cookie] = {

     val cline= Assoc_list::find (fun (a:string,b:string) => eq(a,b)) (request.headers)  ('Cookie');
     val lines = match cline with
       | Some s => (match split(s,';') with
                       |Cons (h,t) => Cons(h,t)
                       |_            => Empty[string]
                     endmatch)
       | _        => Empty[string]
     endmatch;
     val pairs = filter (fun (sl:opt[string^2]) => match sl with |Some _ => true |_ => false endmatch) (map (fun (cl:string) => split_first(cl,"=")) lines);
      return (map (fun (p:opt[string^2]) => let Some q = p in cookie(q.(0),q.(1))) pairs);
}

}
//[http_response.flx]
include "web/__init__";

publish """
Use make_<response type> to wrap html in an apropriate response
"""

class HTTPResponse {
  open LowResTime;
  open HTTPStatusCodes;
  open MIMEType;
  open Assoc_list;
  struct http_response {
    status_code:status_code;
    last_modified:tm;
    content_type:mime_type;
    headers:assoc_list[string,string];
    content:string;
  }

  typedef headers_t = assoc_list[string,string];
  fun no_headers ():headers_t => Empty[string*string];

  fun http_header (response:http_response) =>
"""HTTP/1.0 """ + str(response.status_code) +"""\r
Date: """ + rfc1123_date() + """\r
Server: felix web server\r
Last-Modified: """ + rfc1123_date(response.last_modified) +"""\r
Connection: close\r
Content-Type: """ + str(response.content_type) + """\r
Content-Length: """ + str (len response.content) + """\r
"""+(fold_left (fun(x:string) (y:string):string => x + y) "" (map (fun (n:string*string) => n.(0)+": "+n.(1)+"\r\n") response.headers))+"""\r
""";


  fun make_image(mime:mime_type, content:string) =>
    http_header(http_response(SC_OK,localtime(#time_t),mime,#no_headers,content)) +
      content;

  fun make_image(mime:mime_type, content:string, headers:headers_t) =>
    http_header(http_response(SC_OK,localtime(#time_t),mime,headers,content)) +
      content;

  fun make_css (content:string) =>
    http_header(http_response(SC_OK,localtime(#time_t),text css,#no_headers,content)) +
      content;

  fun make_js (content:string) =>
    http_header(http_response(SC_OK,localtime(#time_t),application javascript,#no_headers,content)) +
      content;

  fun make_json (content:string) =>
    http_header(http_response(SC_OK,localtime(#time_t),application json,#no_headers,content)) +
      content;

  fun make_not_found (content:string) =>
    let response = http_response(SC_NOT_FOUND,localtime(#time_t),text html,#no_headers,
                                content) in
      http_header(response) + response.content;

  fun make_not_implemented (content:string) =>
    let response = http_response(SC_NOT_IMPLEMENTED,localtime(#time_t),text html,#no_headers,
                                content) in
      http_header(response) + response.content;


  fun make_see_other (location:string) =>
    let response = http_response(SC_SEE_OTHER,localtime(#time_t),text html,Cons(("Location",location),Empty[string^2]),"") in
      http_header(response) + response.content;

  fun make_forbidden (content:string) =>
    let response = http_response(SC_FORBIDDEN,localtime(#time_t),text html,#no_headers,
                                "Forbidden: "+content) in
      http_header(response) + response.content;

  fun make_unauthorized (headers:headers_t) =>
    let response = http_response(SC_UNAUTHORIZED,localtime(#time_t),text html,headers,
                                "") in
      http_header(response) +"\nUnauthorized";

  fun make_unauthorized (headers:headers_t,content:string) =>
    let response = http_response(SC_UNAUTHORIZED,localtime(#time_t),text html,headers,
                                "") in
      http_header(response) +"\n"+content;

  fun make_continue () =>
    let response = http_response(SC_CONTINUE,localtime(#time_t),text html,#no_headers,
                                "") in
      http_header(response) +"\r";

  fun make_raw (content:string) => make_raw(content,#no_headers);
  fun make_raw (content:string,headers:headers_t) =>
    http_header(http_response(SC_OK,localtime(#time_t),application octet_DASH_stream,
                              headers,content)) + content;

  fun make_html (content:string) => make_html(content,#no_headers);
  fun make_html (content:string,headers:headers_t) =>
    http_header(http_response(SC_OK,localtime(#time_t),text html,
                              headers,content)) + content;
  fun make_xhtml (content:string) => make_xhtml(content,#no_headers);
  fun make_xhtml (content:string,headers:headers_t) =>
    http_header(http_response(SC_OK,localtime(#time_t),application xhtml_PLUS_xml,
                              headers,content)) + content;

  fun make_mime (mime:mime_type, content:string) => make_mime(mime,content, #no_headers);
  fun make_mime (mime:mime_type, content:string, headers:headers_t) =>
    http_header(http_response(SC_OK,localtime(#time_t),mime,
                              headers,content)) + content;


}
//WWW-Authenticate: Basic realm="WallyWorld"
//[http_handler.flx]
include "web/__init__";

publish """
Implements default handlers for static content and error pages.
Defines container http_hadler for use in constructing custom handlers
for use in WebServer """
class HTTPHandler {
  open HTTPResponse;
  open HTTPRequest;
  open HTTPConnection;
  open ServerConfig;
  open MIMEType;
  open Tord[mime_type];

  publish """ handles determines what requests are handleded by handler_fn.
  handler_fn handles http request and respons on http_connection """
  struct http_handler {
    handles: (server_config*http_request)->bool;
    handler_fn: (http_connection*http_request) -> void;
  }

  publish """ return option of the first element in a list mapped to type V satisfying
  the combined transformer and predicate xf """

 fun / (x:string, y:string) => Filename::join (x,y);

fun find_and_map[T,V] (xf:T -> opt[V]) (xs:list[T]) : opt[V] =>
    match xs with
    | #Empty => None[V]
    | Cons (h,t) => match xf(h) with |Some (v) => Some(v) |_ => find_and_map xf t endmatch
    endmatch
  ;


fun get_fs_path (config:server_config,request:http_request) =>
    match get_path_and_fname(request) with
      | Some(path,fname) => find_and_map[string,string] (fun (r:string):opt[string] => (let fs_path =
        Filename::join(Filename::join(r,path),fname) in
        if (FileStat::fileexists fs_path) then
          Some(fs_path)
        else
          None[string]
        endif)) (list(config.document_root,
          Filename::join(Filename::join(Filename::join(#Config::std_config.FLX_SHARE_DIR,"lib"),"web"),"html")))
      | _ => None[string]
    endmatch;


  fun txt2html (x:string) =
  {
    var out2 = "";
    var i:int;
    for i in 0 upto (int(len x) - 1) do
      var ch = x.[i];
      if ch == char "<" do out2+="&lt;";
      elif ch == char ">" do out2+="&gt;";
      elif ch == char "&" do out2+="&amp;";
      else out2+=ch;
      done
    done
   return out2;
  }

   gen handle_not_found(conn:http_connection, request:http_request) =  {
     var txt = "<div style='text-color:red;'>Page "+
       (match get_fname request with | Some(fname) => fname | _ => "NONE" endmatch)+
       " not found.</div>";
     val data = make_not_found txt;
     write(conn,data);
     return ;
   }

  proc do_handle_not_found(conn:http_connection, request:http_request) {
    handle_not_found(conn,request);
  }

  fun handle_not_found_route (config:server_config, request:http_request) => true;

  gen handle_css(conn:http_connection, request:http_request) = {
    match get_fs_path(conn.config,request) with
      | Some(file) => {
                       val txt = load (file);
                             write(conn,(make_css txt));
                       }
      | _ => {do_handle_not_found(conn,request);}
   endmatch;
   return ;
  }

  fun handle_css_route (config:server_config, request:http_request) =>
    match (get_path_and_fname request) with
       | Some (p,f) => (match (mime_type_from_file f) with |text css => true | _ => false endmatch)
       | _ => false
     endmatch;

  gen handle_js(conn:http_connection, request:http_request) = {
    match get_fs_path(conn.config,request) with
      | Some(file) => {
                       val txt = load (file);
                             write(conn,(make_js txt));
                       }
      | _ => {do_handle_not_found(conn,request);}
   endmatch;
   return ;
  }

  fun handle_js_route (config:server_config, request:http_request) =>
    match (get_path_and_fname request) with
      | Some (p,f) => (match (mime_type_from_file f) with
        |application javascript => true | _ => false endmatch)
      | _ => false
     endmatch;

  gen handle_image(conn:http_connection, request:http_request) = {
    match get_fs_path(conn.config,request) with
      | Some(file) => {
                       val txt = load (file);
                             write(conn,make_image((mime_type_from_file file), txt));
                       }
      | _ => {do_handle_not_found(conn,request);}
   endmatch;
   return ;
  }

  fun handle_image_route (config:server_config,request:http_request) =>
     match (get_path_and_fname request) with
       | Some (p,f) => (match (mime_type_from_file f) with
            |image gif => true
            |image jpeg => true
            |image png => true
            |image tiff => true
            | _ => false endmatch)
       | _ => false
     endmatch;

  gen handle_html(conn:http_connection, request:http_request) = {
    if (request.uri == "/" and request.path == "/") do
      val txt = load (conn.config.document_root+"/index.html");
      write(conn,(make_html txt));
    else
      match get_fs_path(conn.config,request) with
        | Some(file) => {
                       val txt = load (file);
                             write(conn,(make_html txt));
                       }
        | _ => {do_handle_not_found(conn,request);}
       endmatch;
    done
    return ;
  }

  fun handle_html_route (config:server_config,request:http_request):bool =>
     if (request.uri == "/" and request.path == "/") then
       true
     else
       match (get_path_and_fname request) with
         | Some (p,f) => (match (mime_type_from_file f) with |text html => true | _ => false endmatch)
         | _ => false
       endmatch
     endif;

  publish """ Returns list of Stock handlers """
  fun default_handlers() => list (
    http_handler(handle_html_route,handle_html),
        http_handler(handle_image_route,handle_image),
    http_handler(handle_css_route,handle_css),
              http_handler(handle_js_route,handle_js),
    http_handler(handle_not_found_route,handle_not_found)
  );

}
//[http_connection.flx]
include "web/__init__";

publish """
Container for server config and socket_t
"""
class HTTPConnection {
  open ServerConfig;
  open Socket;
  open Logger;
  open IOStream;
  open Socket;
  open TerminalIOByteStream[socket_t];

  struct http_connection {
    config:server_config;
    sock:socket_t;
    dirty:&bool;
  };
  fun _ctor_http_connection(config:server_config,sock:socket_t) = {
    var b:bool = false;
    return http_connection(config,sock,&b);
  }
  proc set_dirty(conn:http_connection,state:bool) {
    conn.dirty <- state;
  }

  noinline proc write(var conn:http_connection,var content:string) {

    var eof_flag = false;
    val content_len = content.len;
    conn.config.log(DEBUG,"Content Size:"+str(content_len));
    val chunk_size = size(1024);
    var chunks:size = content.len / chunk_size;
    var remainder = content.len % chunk_size;
    var base = size(0);
    for var i in size(1) upto chunks do
      conn.config.log(DEBUG,"Writing[sock="+str conn.sock+"]:"+str(base)+" to "+str(base+chunk_size));
      write_string(conn.sock,content.[base to (base+chunk_size)],&eof_flag);
      base = base + chunk_size;

    done
    if remainder > size(0) do
       conn.config.log(DEBUG,"Writing[sock="+str conn.sock+"] Remainder:"+str(base)+" to "+str(content_len));
       write_string(conn.sock,content.[base to ],&eof_flag);
    done
    set_dirty(conn,true);
  }

}
//[http_status_code.flx]
/*
Example:
  println$ str SC_OK;
*/

class HTTPStatusCodes {
  enum status_code {
    SC_OK,
    SC_CREATED,
    SC_NO_CONTENT,
    SC_MOVED_PERMANENTLY,
    SC_TEMPORARY_REDIRECT,
    SC_BAD_REQUEST,
    SC_UNAUTHORIZED,
    SC_FORBIDDEN,
    SC_NOT_FOUND,
    SC_METHOD_NOT_ALLOWED,
    SC_INTERNAL_SERVER_ERROR,
    SC_NOT_IMPLEMENTED,
    SC_SERVICE_UNAVAILABLE,
    SC_SEE_OTHER,
    SC_CONTINUE
  }

  instance Str[status_code] {
    fun str: status_code -> string =
      |  #SC_CONTINUE => "100 Continue"
      |  #SC_OK => "200 OK"
      |  #SC_CREATED => "201 Created"
      |  #SC_NO_CONTENT => "204 No Content"
      |  #SC_MOVED_PERMANENTLY => "301 Moved Permanently"
      |  #SC_SEE_OTHER => "303 See Other"
      |  #SC_TEMPORARY_REDIRECT => "307 Temporary Redirect"
      |  #SC_BAD_REQUEST => "400 Bad Request"
      |  #SC_UNAUTHORIZED => "401 Unauthorized"
      |  #SC_FORBIDDEN => "403 Forbidden"
      |  #SC_NOT_FOUND => "404 Not Found"
      |  #SC_METHOD_NOT_ALLOWED => "405 Not Allowed"
      |  #SC_INTERNAL_SERVER_ERROR => "500 Internal Server Error"
      |  #SC_NOT_IMPLEMENTED => "501 Not Implemented"
      |  #SC_SERVICE_UNAVAILABLE => "503 Service Unavailable"
    ;
  }

}
//[mime_type.flx]
publish """
Implements variant types representing MIME types.
Also implements Str instance for mime types and parses MIME type from string

Example:
  open MIMETypes;
  println (javascript);
  println from_str("application/atom+xml");
  println (application zip);
"""

class MIMEType {
/*
TODO: implement more MIME types.
*/

  open WebUtil;
  variant application_mime_subtype =
    | atom_PLUS_xml //: Atom feeds
    | ecmascript // ECMAScript/JavaScript; Defined in RFC 4329
    | EDI_DASH_X12 // EDI X12 data; Defined in RFC 1767
    | EDIFACT  //EDI EDIFACT data; Defined in RFC 1767
    | json // JavaScript Object Notation JSON; Defined in RFC 4627
    | javascript // ECMAScript/JavaScript; Defined in RFC 4329
    | octet_DASH_stream // Arbitrary binary data.
    | ogg // Ogg, a multimedia bitstream container format;
    | pdf // Portable Document Format,
    | postscript // PostScript; Defined in RFC 2046
    | rss_PLUS_xml // RSS feeds
    | soap_PLUS_xml //SOAP; Defined by RFC 3902
    | font_DASH_woff //: Web Open Font Format;
    | xhtml_PLUS_xml //: XHTML; Defined by RFC 3236
    | xml_DASH_dtd //: DTD files; Defined by RFC 3023
    | xop_PLUS_xml //:XOP
    | zip //: ZIP archive files; Registered[7]
    | x_DASH_gzip //: Gzip
    | x_DASH_www_DASH_form_DASH_urlencoded;

  variant audio_mime_subtype =
    | basic //: mulaw audio at 8 kHz, 1 channel; Defined in RFC 2046
    | L24 //: 24bit Linear PCM audio at 8-48kHz, 1-N channels; Defined in RFC 3190
    | mp4 //: MP4 audio
    | mpeg //: MP3 or other MPEG audio; Defined in RFC 3003
    | ogg1 //: Ogg Vorbis, Speex, Flac and other audio; Defined in RFC 5334
    | vorbis //: Vorbis encoded audio; Defined in RFC 5215
    | x_DASH_ms_DASH_wma //: Windows Media Audio; Documented in Microsoft KB 288102
    | x_DASH_ms_DASH_wax //: Windows Media Audio Redirector
    | vnd_DOT_rn_DASH_realaudio //: RealAudio; Documented in RealPlayer
    | vnd_DOT_wave //: WAV audio; Defined in RFC 2361
    | webm //: WebM open media format
  ;

  variant image_mime_subtype =
    | gif //: GIF image; Defined in RFC 2045 and RFC 2046
    | jpeg // JPEG JFIF image; Defined in RFC 2045 and RFC 2046
    | pjpeg //: JPEG JFIF image; Associated with Internet Explorer;
    | png //: Portable Network Graphics; Registered,[8] Defined in RFC 2083
    | svg_PLUS_xml //: SVG vector image; Defined in SVG Tiny 1.2 Specification Appendix M
    | tiff // Tag Image File Format (only for Baseline TIFF); Defined in RFC 3302
    | vnd_DOT_microsoft_DOT_icon //: ICO image; Registered[9]
  ;

  variant text_mime_subtype =
    | cmd //: commands; subtype resident in Gecko browsers like Firefox 3.5
    | css //: Cascading Style Sheets; Defined in RFC 2318
    | csv //: Comma-separated values; Defined in RFC 4180
    | html //: HTML; Defined in RFC 2854
    | javascript1 //(Obsolete): JavaScript; Defined in and obsoleted by RFC 4329
    | plain //: Textual data; Defined in RFC 2046 and RFC 3676
    | vcard //: vCard (contact information); Defined in RFC 6350
    | xml //: Extensible Markup Language; Defined in RFC 3023
    | x_DASH_felix
    | x_DASH_fdoc
    | x_DASH_fpc
    | x_DASH_c
    | x_DASH_ocaml
    | x_DASH_python
  ;

  variant multipart_mime_subtype =
    | mixed
    | alternative
    | related
    | form-data
    | signed
    | encrypted;

  variant mime_type =
    | application of application_mime_subtype
    | audio of audio_mime_subtype
    | image of image_mime_subtype
    | text of text_mime_subtype
    | multipart of multipart_mime_subtype;

  typedef media_type =  mime_type * list[string^2];

  instance Str[application_mime_subtype] {
    fun str : application_mime_subtype ->string =
      | #atom_PLUS_xml => "application/atom+xml"
      | #ecmascript => "application/ecmascript"
      | #EDI_DASH_X12 => "application/EDI-X12"
      | #EDIFACT => "application/EDIFACT"
      | #json => "application/json"
      | #javascript => "application/javascript"
      | #octet_DASH_stream => "application/octet-stream"
      | #ogg => "application/ogg"
      | #pdf => "application/pdf"
      | #postscript => "appliction/postscript"
      | #rss_PLUS_xml => "application/rss+xml"
      | #soap_PLUS_xml => "application/soap+xml"
      | #font_DASH_woff => "application/font-woff"
      | #xhtml_PLUS_xml => "application/xhtml+xml"
      | #xml_DASH_dtd => "application/xml-dtd"
      | #xop_PLUS_xml => "application/xop+xml"
      | #zip => "application/zip"
      | #x_DASH_gzip => "application/x-gzip"
      | #x_DASH_www_DASH_form_DASH_urlencoded => "application/x-www-form-urlencoded";
 }

 instance Str[audio_mime_subtype] {
   fun str : audio_mime_subtype ->string =
     | #basic => "audio/basic"
     | #L24 => "audio/L24"
     | #mp4 => "audio/mp4"
     | #mpeg => "audio/mpeg"
     | #ogg1 => "audop/ogg"
     | #vorbis => "audio/vorbis"
     | #x_DASH_ms_DASH_wma => "audio/x-ms-wma"
     | #x_DASH_ms_DASH_wax => "audio/x-ms-wax"
     | #vnd_DOT_rn_DASH_realaudio => "audio/vnd.rn-realaudio"
     | #vnd_DOT_wave => "audio/vnd.wave"
     | #webm => "audio/webm";
  }

  instance Str[image_mime_subtype] {
    fun str : image_mime_subtype ->string =
      | #gif => "image/gif"
      | #jpeg => "image/jpeg"
      | #pjpeg => "image/pjpeg"
      | #png => "image/png"
      | #svg_PLUS_xml => "image/svg+xml"
      | #tiff => "image/tiff"
      | #vnd_DOT_microsoft_DOT_icon => "image/vnd.microsoft.icon";
  }

  instance Str[text_mime_subtype] {
    fun str : text_mime_subtype ->string =
      | #cmd => "text/cmd"
      | #css => "text/css"
      | #csv => "text/csv"
      | #html => "text/html"
      | #javascript1 => "text/javascript"
      | #plain => "text/plain"
      | #vcard => "text/vcard"
      | #xml => "text/xml"
      | #x_DASH_felix => "text/x-felix"
      | #x_DASH_fdoc => "text/x-fdoc"
      | #x_DASH_fpc => "text/x-fpc"
      | #x_DASH_c => "text/x-c"
      | #x_DASH_ocaml => "text/x-ocaml"
      | #x_DASH_python => "text/x-python";
  }

  instance Str[multipart_mime_subtype] {
    fun str : multipart_mime_subtype ->string =
      | #mixed => "multipart/mixed"
      | #alternative => "multipart/alternative"
      | #related => "multipart/related"
      | #form-data => "multipart/form-data"
      | #signed => "multipart/signed"
      | #encrypted => "multipart/encrypted";
  }

  instance Str[mime_type] {
    fun str : mime_type ->string =
      | application  a => str a
      | audio  a => str a
      | image  a => str a
      | text  a => str a
      | multipart  a => str a;
  }

  fun application_type_from_str : string -> opt[application_mime_subtype] =
    | "application/atom+xml"     => Some atom_PLUS_xml
    | "application/ecmascript"   => Some ecmascript
    | "application/EDI-X12"      => Some EDI_DASH_X12
    | "application/EDIFACT"      => Some EDIFACT
    | "application/json"         => Some json
    | "application/javascript"   => Some javascript
    | "application/octet-stream" => Some octet_DASH_stream
    | "application/ogg"          => Some ogg
    | "application/pdf"          => Some pdf
    | "appliction/postscript"    => Some postscript
    | "application/rss+xml"      => Some rss_PLUS_xml
    | "application/soap+xml"     => Some soap_PLUS_xml
    | "application/font-woff"    => Some font_DASH_woff
    | "application/xhtml+xml"    => Some xhtml_PLUS_xml
    | "application/xml-dtd"      => Some xml_DASH_dtd
    | "application/xop+xml"      => Some xop_PLUS_xml
    | "application/zip"          => Some zip
    | "application/x-gzip"       => Some x_DASH_gzip
    | "application/x-www-form-urlencoded" => Some x_DASH_www_DASH_form_DASH_urlencoded
    | _                          => None[application_mime_subtype];

  fun audio_type_from_str : string -> opt[audio_mime_subtype] =
    |  "audio/basic" => Some basic
    |  "audio/L24" => Some L24
    |  "audio/mp4" => Some mp4
    |  "audio/mpeg" => Some mpeg
    |  "audop/ogg" => Some ogg1
    |  "audio/vorbis" => Some vorbis
    |  "audio/x-ms-wma" => Some x_DASH_ms_DASH_wma
    |  "audio/x-ms-wax" => Some x_DASH_ms_DASH_wax
    |  "audio/vnd.rn-realaudio" => Some vnd_DOT_rn_DASH_realaudio
    |  "audio/vnd.wave" => Some vnd_DOT_wave
    |  "audio/webm" => Some webm
    |  _ => None[audio_mime_subtype] ;

  fun image_type_from_str : string -> opt[image_mime_subtype] =
    | "image/gif" => Some gif
    | "image/jpeg" => Some jpeg
    | "image/pjpeg" => Some pjpeg
    | "image/png" => Some png
    | "image/svg+xml" => Some svg_PLUS_xml
    | "image/tiff" => Some tiff
    | "image/vnd.microsoft.icon" => Some vnd_DOT_microsoft_DOT_icon
    | _ => None[image_mime_subtype];

  fun text_type_from_str : string -> opt[text_mime_subtype] =
    | "text/cmd" => Some cmd
    | "text/css" => Some css
    | "text/csv" => Some csv
    | "text/html" => Some html
    | "text/javascript" => Some javascript1
    | "text/plain" => Some plain
    | "text/vcard" => Some vcard
    | "text/xml" => Some xml
    | "text/x-felix" => Some x_DASH_felix
    | "text/x-fdoc" => Some x_DASH_fdoc
    | "text/x-fpc" =>  Some x_DASH_fpc
    | "text/x-c"  => Some x_DASH_c
    | "text/x-ocaml"  => Some x_DASH_ocaml
    | "text/x-python" => Some x_DASH_python
    | _ => None[text_mime_subtype];

  fun multipart_type_from_str : string -> opt[multipart_mime_subtype] =
    | "multipart/mixed" => Some mixed
    | "multipart/alternative" => Some alternative
    | "multipart/related" => Some related
    | "multipart/form-data" => Some form-data
    | "multipart/signed" => Some signed
    | "multipart/encrypted" => Some encrypted
  ;

  fun from_str (s:string):opt[mime_type] =>
    match application_type_from_str s with
      | Some t => Some (application t)
      | #None => match audio_type_from_str s with
        | Some t =>  Some (audio t)
        | #None => match image_type_from_str s with
           | Some t => Some (image t)
           | #None => match text_type_from_str s with
             | Some t => Some (text t)
             | #None => match multipart_type_from_str s with
               | Some t => Some (multipart t)
               | #None => None[mime_type]
             endmatch
           endmatch
         endmatch
       endmatch
     endmatch;

  fun mime_type_from_file(file:string) =>
    match rev(split(file,'.')) with
    | Cons(hd,_) => mime_type_from_extension hd
    | _ => text plain
    endmatch;

  fun mime_type_from_extension: string -> mime_type =
    | "atom" => application atom_PLUS_xml
    | "ecma" => application ecmascript
    | "json" => application json
    | "js" => application javascript
    | "application/octet-stream" => application octet_DASH_stream
    | "ogg" => application ogg
    | "ogx" => application ogg
    | "pdf" => application pdf
    | "ps" => application postscript
    | "eps" => application postscript
    | "ai" => application postscript
    | "xhtml" => application xhtml_PLUS_xml
    | "xht" => application xhtml_PLUS_xml
    | "dtd" => application xml_DASH_dtd
    | "xop" => application xop_PLUS_xml
    | "zip" => application zip
    | "x-gzip" => application x_DASH_gzip
    | "au" => audio basic
    | "snd" => audio basic
    | "mp4a" => audio mp4
    | "mpega" => audio mpeg
    | "mpga" => audio mpeg
    | "mp2a" => audio mpeg
    | "mp3a" => audio mpeg
    | "mp4a" => audio mpeg
    | "mp2" => audio mpeg
    | "mp3" => audio mpeg
    | "ogg" => audio ogg1
    | "oga" => audio ogg1
    | "spx" => audio ogg1
    | "wma" => audio x_DASH_ms_DASH_wma
    | "wax" => audio x_DASH_ms_DASH_wax
    | "ra" => audio vnd_DOT_rn_DASH_realaudio
    | "wav" => audio vnd_DOT_wave
    | "webma" => audio webm
    | "gif" => image gif
    | "image/jpeg" => image jpeg
    | "jpg" => image jpeg
    | "pjpeg" => image pjpeg
    | "png" => image png
    | "svg" => image svg_PLUS_xml
    | "tiff" => image tiff
    | "css" => text css
    | "csv" => text csv
    | "html" => text html
    | "htm" => text html
    | "shtm" => text html
    | "text/plain" => text plain
    | "asc" => text plain
    | "conf" => text plain
    | "def" => text plain
    | "diff" => text plain
    | "in" => text plain
    | "list" => text plain
    | "log" => text plain
    | "pot" => text plain
    | "text" => text plain
    | "txt" => text plain
    | _ => text plain
  ;


instance Eq[mime_type]  {
  fun == : mime_type * mime_type -> bool = "$1==$2";
}


  fun parse_media_type (s:string):opt[media_type] =>
    match split( s, ";") with
    | Cons(h,t) =>
      match from_str(h) with
      | Some m => Some (m,parse_attribute_list(t))
      | _       => None[media_type]
      endmatch
    | _ => None[media_type]
    endmatch
  ;

//instance Tord[test_mime_subtype] {
//    fun eq: t * t -> bool = "$1==$2";
//}
//open Tord[text_mime_subtype];
open Tord[mime_type];
/*
Other unimplemented types:
Type message
message/http: Defined in RFC 2616
message/imdn+xml: IMDN Instant Message Disposition Notification; Defined in RFC 5438
message/partial: Email; Defined in RFC 2045 and RFC 2046
message/rfc822: Email; EML files, MIME files, MHT files, MHTML files; Defined in RFC 2045 and RFC 2046
Type model
For 3D models.
model/example: Defined in RFC 4735
model/iges: IGS files, IGES files; Defined in RFC 2077
model/mesh: MSH files, MESH files; Defined in RFC 2077, SILO files
model/vrml: WRL files, VRML files; Defined in RFC 2077
model/x3d+binary: X3D ISO standard for representing 3D computer graphics, X3DB binary files
model/x3d+vrml: X3D ISO standard for representing 3D computer graphics, X3DV VRML files
model/x3d+xml: X3D ISO standard for representing 3D computer graphics, X3D XML files
Type multipart
Type video
For video.
video/mpeg: MPEG-1 video with multiplexed audio; Defined in RFC 2045 and RFC 2046
video/mp4: MP4 video; Defined in RFC 4337
video/ogg: Ogg Theora or other video (with audio); Defined in RFC 5334
video/quicktime: QuickTime video; Registered[10]
video/webm: WebM Matroska-based open media format
video/x-matroska: Matroska open media format
video/x-ms-wmv: Windows Media Video; Documented in Microsoft KB 288102
Type vnd
For vendor-specific files.
application/vnd.oasis.opendocument.text: OpenDocument Text; Registered[11]
application/vnd.oasis.opendocument.spreadsheet: OpenDocument Spreadsheet; Registered[12]
application/vnd.oasis.opendocument.presentation: OpenDocument Presentation; Registered[13]
application/vnd.oasis.opendocument.graphics: OpenDocument Graphics; Registered[14]
application/vnd.ms-excel: Microsoft Excel files
application/vnd.openxmlformats-officedocument.spreadsheetml.sheet: Microsoft Excel 2007 files
application/vnd.ms-powerpoint: Microsoft Powerpoint files
application/vnd.openxmlformats-officedocument.presentationml.presentation: Microsoft Powerpoint 2007 files
application/msword: Microsoft Word files
application/vnd.openxmlformats-officedocument.wordprocessingml.document: Microsoft Word 2007 files
application/vnd.mozilla.xul+xml: Mozilla XUL files
application/vnd.google-earth.kml+xml: KML files (e.g. for Google Earth)
Type x
For non-standard files.
application/x-www-form-urlencoded Form Encoded Data; Documented in HTML 4.01 Specification, Section 17.13.4.1
application/x-dvi: device-independent document in DVI format
application/x-latex: LaTeX files
application/x-font-ttf: TrueType Font No registered MIME type, but this is the most commonly used
application/x-shockwave-flash: Adobe Flash files for example with the extension .swf
application/x-stuffit: StuffIt archive files
application/x-rar-compressed: RAR archive files
application/x-tar: Tarball files
text/x-gwt-rpc: GoogleWebToolkit data
text/x-jquery-tmpl: jQuery template data
application/x-javascript:
application/x-deb: deb_(file_format), a software package format used by the Debian project
[edit]Type x-pkcs
For PKCS standard files.
application/x-pkcs12: p12 files
application/x-pkcs12: pfx files
application/x-pkcs7-certificates: p7b files
application/x-pkcs7-certificates: spc files
application/x-pkcs7-certreqresp: p7r files
application/x-pkcs7-mime: p7c files
application/x-pkcs7-mime: p7m files
application/x-pkcs7-signature: p7s files
*/
}
//[cookie.flx]
include "web/low_res_time";

class Cookie {
  open LowResTime;
  open WebUtil;

  struct cookie {
    name:string;
    value:string;
    domain:string;
    path:string;
    expires:string;
    secure:bool;
    http_only:bool;
  }

  fun _ctor_cookie (n:string,v:string) = {
    var c:cookie;c&.name<-n;c&.value<-v;return c;}



  instance Str[cookie] {
    fun str (c:cookie) => c.name+"="+c.value+"; "+match c.domain with
      |'' => ' ' | d => "Domain="+d+"; " endmatch+
      match c.path with |'' => ' ' |p => "Path="+p+"; " endmatch+
      match c.expires with |'' => ' ' |e => " Expires="+e+"; " endmatch+
      (if c.secure then "Secure; " else " " endif)+
      (if c.http_only then "HttpOnly;" else "" endif);
  }

  fun set_cookie (c:cookie):string*string => ("Set-Cookie",str(c));
  fun set_cookies (c:list[cookie]):string*string => ("Set-Cookie",
    fold_left (fun(x:string) (y:string):string => y +"\r"+ x) ""
      (map (fun(z:cookie):string => str(z)) c));

}
//[low_res_time.flx]
class LowResTime
{
  open C_hack;

  requires C89_headers::time_h;

  type time_t = "time_t";
  fun +: time_t*time_t -> time_t = "$1+$2";
  fun +: time_t*int -> time_t = "$1+(time_t)$2";

  //$ Current time
  proc time: &time_t = "time($1);";

  //$ Current time
  ctor time_t () = {
    var time_v:time_t;
    time(&time_v);
    return time_v;
  }


  // cast integer (in second since epoch) to time
  ctor time_t: !ints = "(time_t)$1:cast" is cast;

  cstruct tm {
    tm_sec:int;         /* seconds */
    tm_min:int;         /* minutes */
    tm_hour:int;        /* hours */
    tm_mday:int;        /* day of the month */
    tm_mon:int;         /* month */
    tm_year:int;        /* year */
    tm_wday:int;        /* day of the week */
    tm_yday:int;        /* day in the year */
    tm_isdst:int;       /* daylight saving time */
  };


if PLAT_WIN32 do
  private proc gmtime:&time_t * &tm = "gmtime_s($2,$1);";
else
  private proc gmtime:&time_t * &tm = "gmtime_r($1,$2);";
done

  fun gmtime (var t:time_t) :tm =
  {
    var atm : tm; gmtime (&t, &atm);
    return atm;
  }

if PLAT_WIN32 do
  private proc localtime:&time_t * &tm = "localtime_s($2,$1);";
else
  private proc localtime:&time_t * &tm = "localtime_r($1,$2);";
done
  fun localtime (var t:time_t) :tm =
  {
    var atm : tm; localtime (&t, &atm);
    return atm;
  }

  header """
    string asctime_helper(struct tm const * ti);
  """;

if PLAT_WIN32 do
  body """
    string asctime_helper(struct tm const * ti) {
      int len = 64;
      char *fmted = (char*) ::std::malloc(sizeof(char)*64);
      asctime_s(fmted,64,ti);
      string s = string(fmted);
      ::std::free(fmted);
      return s;
    }
  """;
else
  body """
    string asctime_helper(struct tm const * ti) {
      int len = 64;
      char *fmted = (char*) ::std::malloc(sizeof(char)*64);
      asctime_r(ti,fmted);
      string s = string(fmted);
      ::std::free(fmted);
      return s;
    }
  """;
done

  private fun asctime:&tm -> string = "asctime_helper($1)";
  fun asctime (var t:tm) : string => asctime (&t);

  header """
    string strftime_helper(const char *pat,    const struct tm * ti);
  """;

  body """
    string strftime_helper(const char *pat,    const struct tm * ti) {
      int len = 64;
      char *fmted = (char*) ::std::malloc(sizeof(char)*64);
      strftime(fmted,len,pat,ti);
      string s = string(fmted);
      ::std::free(fmted);
      return s;
    }
  """;

  private fun strftime: string * &tm -> string = "strftime_helper(($1.c_str()),$2)";
  fun strftime (fmt: string, var t: tm ) :string =
  {
     return strftime (fmt, &t);
  }

  fun rfc1123_date (dt:&tm) => strftime("%a, %d %b %Y %H:%M:%S %Z",dt);
  fun rfc1123_date (dt:tm) => strftime("%a, %d %b %Y %H:%M:%S %Z",dt);

  fun rfc1123_date () = {
    var time_epoch_seconds = time_t();
    var tm_struct : tm;
    gmtime(&time_epoch_seconds, &tm_struct);
    return rfc1123_date(&tm_struct);
  }

  fun hour() => 3600;

  fun day() => 86400;
  fun expires_seconds_from_now(seconds:int) ={
    var time_epoch_seconds = time_t() +seconds;
    var tm_struct : tm;
    gmtime(&time_epoch_seconds, &tm_struct);
   return rfc1123_date (&tm_struct);
 }

}
//[json.flx]
open class Json
{
  variant Jvalue =
  | Jstring of string
  | Jnumber of string
  | Jdictionary of list[Jpair]
  | Jarray of list [Jvalue]
  | Jname of string
  ;
  typedef Jpair = Jvalue * Jvalue;

  fun str (s:Jvalue, v:Jvalue) : string => str s + ': ' + str v;

  fun str (v: Jvalue) : string => match v with
  | Jstring s => '"' + s + '"' // hack, ignores quoting rules
  | Jnumber i => i
  | Jdictionary d => "{" + cat ", " (map str of (Jpair) d) + "}"
  | Jarray a => "[" + cat ", " (map str of (Jvalue) a) + "]"
  | Jname a => a
  endmatch
  ;

  variant ParseResult =
  | Good of Jvalue
  | Bad of int
  ;

  fun parse_json(s:string): ParseResult = {
    var i = skip_white s 0;
    def i, var v = parse_value s i;
    i = skip_white s i;
    if s.[i] != "".char do
      return Bad i;
    else
      return v;
    done
  }

  private fun skip_white (s:string) (var i:int) = {
    while s.[i] in " \t\r\n" do ++i; done
    return i;
  }

  private fun parse_value (s:string) (i:int): int * ParseResult =>
    if s.[i] in "-0123456789" then parse_number s i
    elif s.[i] == '"'.char then parse_string s (i+1)
    elif s.[i] == "{".char then parse_dictionary s (i+1)
    elif s.[i] ==  "[".char then parse_array s (i+1)
    elif s.[i] in "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" then parse_name s i
    else i, Bad i
    endif
  ;

  private fun parse_name (s:string) (var i:int) = {
    var j = s.[i].string;
    ++i;
    while s.[i] in "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_" do
       j += s.[i];
       ++i;
    done
    if j in ("true","false","null") do
      return i,Good (Jname j);
    else
      return i, Bad i;
    done
  }

  private fun parse_number (s:string) (var i:int) = {
    var j = "";

    // optional leading sign
    if s.[i] == "-".char do
      j += s.[i];
      ++i;
    done

    // zero integral part
    if s.[i] == "0".char do
      j+= s.[i];
      ++i;
      goto point;
    done

    // nonzero integral part
    if s.[i] in "123456789" do
      j += s.[i];
      ++i;
    else
      goto bad;
    done

    // rest of integral part
    while s.[i] in "0123456789" do
       j += s.[i];
       ++i;
    done

point:>
    if s.[i] != ".".char goto exponent;
    j += s.[i];
    ++i;

fraction:>
    if s.[i] in "0123456789" do
      while s.[i] in "0123456789" do
         j += s.[i];
         ++i;
      done
    else
      goto bad;
    done

exponent:>
    if s.[i] in "eE" do
      j += s.[i];
      ++i;
    else
      goto good;
    done

    // sign of exponent
    if s.[i] in "+-" do
      j += s.[i];
      ++i;
    done

    // exponent value
    if s.[i] in "0123456789" do
      while s.[i] in "0123456789" do
      j += s.[i];
      ++i;
      done
    else
      goto bad;
    done
good:>
    return i,Good (Jnumber j);
bad:>
    return i, Bad i;
  }

  private fun parse_string (s:string) (var i:int) = {
    var r = "";
ordinary:>
    while s.[i] != "".char and s.[i] != '"'.char and s.[i] != "\\".char do
      if s.[i].ord < 32 goto bad; // control chars are not allowed
      r += s.[i];
      ++i;
    done

    if s.[i] == '"'.char do // closing quote
      ++i;
      goto good;
    elif s.[i] == "\\".char do // escape
      r += s.[i];
      ++i;
      if s.[i] in '"\\/bfnrt' do // one char escape code
        r += s.[i];
        ++i;
        goto ordinary;
      elif s.[i] == "u".char do // hex escape
        r += s.[i];
        ++i;
        if s.[i] in "0123456789ABCDEFabcdef" do r += s.[i]; ++i; else goto bad; done
        if s.[i] in "0123456789ABCDEFabcdef" do r += s.[i]; ++i; else goto bad; done
        if s.[i] in "0123456789ABCDEFabcdef" do r += s.[i]; ++i; else goto bad; done
        if s.[i] in "0123456789ABCDEFabcdef" do r += s.[i]; ++i; else goto bad; done
        goto ordinary;
      else
        goto bad;
      done
    else // end of input
      goto bad;
    done

good:>
    return i,Good (Jstring r);
bad:>
    return i, Bad i;
}

  private fun parse_dictionary (s:string) (var i:int) = {
    var elts = #list[Jvalue * Jvalue];
    i = skip_white s i;
    while s.[i] != "}".char do
      if s.[i] == '"'.char do
        def i, var ms = parse_string s (i+1);
        match ms with
        | Good sv =>
          i = skip_white s i;
          if s.[i] == ":".char do
            ++i;
            i = skip_white s i;
            def i, var mv = parse_value s i;
            match mv with
            | Good v =>
              elts += sv,v;
              i = skip_white s i;
            | Bad j => return i, Bad j;
            endmatch;
          else
            return i, Bad i;
          done
          if s.[i] == ",".char do
            ++i;
            i = skip_white s i;
          elif s.[i] == "}".char do ;
          else
            return i, Bad i;
          done
        | Bad j => return i, Bad j;
        endmatch;
      else
        return i, Bad i;
      done
    done
    ++i;
    i = skip_white s i;
    return i, Good (Jdictionary elts);
  }

  private fun parse_array (s:string) (var i:int) = {
    var elts = #list[Jvalue];
    i = skip_white s i;
    while s.[i] != "]".char do
      def i, var mv = parse_value s i;
      match mv with
      | Good v => elts += v;
        i = skip_white s i;
        if s.[i] == ",".char do
          ++i;
          i = skip_white s i;
        elif s.[i] == "]".char do ;
        else
          return i, Bad i;
        done
      | Bad j => return i, Bad j;
      endmatch;
    done
    ++i;
    i = skip_white s i;
    return i, Good (Jarray elts);
  }
}
//[logger.flx]
publish """
Extensible Flexible Logger
example:
/* Creates two log files, my_info.log rolls over when log size exceeds 1024 bytes
   and is archived 4 times. my_debug.log does not roll over and will grow to infinite size.
   log messages with log_level INFO are routed to my_info.log.log messages with log level DEBUG
   are routed to my_debug.log */
open Logger;
var mylog = logger(simple_logger(
  Logger::log("log","my.log",size(1024),4ui),   INFO)+
  simple_logger(Logger::log("log","my_debug.log",size(0),0ui),  DEBUG));
mylog(DEBUG,"Debugging enabled");
"""
class Logger {

  open LowResTime;

  struct log {
    path:string;
    name:string;
    max_size:size;
    archives:uint;
  }

  publish """ Log Level definitions """
  variant log_level =
    | INFO
    | WARNING
    | ERROR
    | ACCESS
    | DEBUG
    | CUSTOM1
    | CUSTOM2;

  publish """ Definition of log_message """
  typedef log_message = log_level*string;

  publish """
  Container for log handler. handles governs what log messages are sent to handles_fn
  """
  struct log_handler {
    handles: (log_message)->bool;
    handler_fn: (log_message) -> void;
  }

  publish """
  Simple predicate generator. Returns closusre matching message against curried
  parameter handles
  """
  fun simple_log_handles [with Eq[log_level]] (handles:log_level) (message:log_message) =>
    handles == message.(0);

  publish """
  Simple log handler implementation. Creates log file give log_path and log_file
  and returns clousre accepting log_message writeing to files specified
  """
  gen simple_log_handler_fn (l:log):(log_message)->void = {
    var log_handle = open_log(l); //fopen_output (l.path+"/"+l.name);
    return (proc (message:log_message)  {
              log_handle = rotate_when_larger_than_max_size(log_handle,l);
              fprintln (log_handle, "["+log_date()+"]"+" "+to_str(message));
              fflush(log_handle);
            });
  }

  publish """
  Simple log handler implementation for logging to console.
  """
  fun console_log_handler_fn ():(log_message)->void = {
    return (proc (message:log_message)  {
              println ("["+log_date()+"]"+" "+to_str(message));
            });
  }

  publish """
  Convience log_handler creator for simple logger
  """
  fun simple_logger (l:log,level:log_level):list[log_handler] =>
   list(log_handler ((simple_log_handles(level))  ,
                simple_log_handler_fn(l)));

  publish """
  Convience log_handler creator for simple console logger
  """
  fun console_logger (level:log_level):list[log_handler] =>
   list(log_handler ((simple_log_handles(level))  ,
                      console_log_handler_fn()));


  publish """
  Generates logger handle used for sending messages to defined loggers.
  Accepts a list of log_handler and returns a closure accepting log_message
  writing to matching log handler
  """
  fun logger(handlers:list[log_handler]):log_message->void =  {
    var channel = mk_schannel[log_message]();
    spawn_fthread (listener(channel,handlers));
    return sender(channel);
  }

  publish  """Log writer runs as fthread"""
  private proc listener(chan:schannel[log_message],log_handlers:list[log_handler]) (){
    while true do
      var log_req:log_message = read chan;
      iter (proc (handler:log_handler) {
        if handler.handles log_req do
          handler.handler_fn(log_req);
        done
      }) log_handlers;
    done
    return;
  }

  private proc sender (log_channel:schannel[log_message]) (message:log_message) {
    write (log_channel,message);
  }

  instance Str[log_level] {
    fun str : log_level ->string =
      | #INFO => "[INFO]"
      | #WARNING  => "[WARNING]"
      | #ERROR  => "[ERROR]"
      | #ACCESS => "[ACCESS]"
      | #DEBUG => "[DEBUG]"
      | #CUSTOM1 => "[CUSTOM1]"
      | #CUSTOM2 => "[CUSTOM2]";
  }


  instance Eq[log_level]  {
    fun == : log_level * log_level -> bool = "$1==$2";
  }

  fun to_str (m:log_message):string  =>
       str(m.(0))+"\t"+m.(1);

  fun log_date_fmt (dt:tm) => strftime("%d/%b/%Y:%H:%M:%S %Z",dt);

  fun log_date () = {
    var time_epoch_seconds = time_t();
    val tm_struct =  gmtime(time_epoch_seconds);
    return log_date_fmt(tm_struct);
  }

  fun open_log(l:log):ofile = {
    val log_file = l.path+"/"+l.name;
    if (FileStat::fileexists log_file) and l.archives > 0ui do
      l.rotate();
    done
    var log_handle = fopen_output (log_file);
    if not valid log_handle do
      eprintln("Unable to open log at "+log_file+".\nLogging to console instead.");
      return stdout;
    else
      return log_handle;
    done
  }


  proc rotate(l:log) {
    val log_file = l.path+"/"+l.name;
    if FileStat::fileexists log_file do
      var last ="";
      for var i in l.archives downto 1ui  do
        val rlog =  log_file+"."+str(i) ;
        if FileStat::fileexists rlog and last != "" do
          if 0 != (FileSystem::rename_file (rlog, (log_file+"."+str(i+1ui)))) do
            eprintln("Unable to rotate log "+rlog+" to "+log_file+"."+str(i+1ui));
          done
        done
        last = rlog;
      done
      if 0 != (FileSystem::rename_file (log_file,(log_file+".1"))) do
        eprintln("Unable to rotate log "+log_file+" to "+log_file+".1");
      done
    done
  }

  fun rotate_when_larger_than_max_size(handle:ofile,l:log) = {
    if  l.max_size > size(0) and fsize(l.path+"/"+l.name) > l.max_size do
       if valid(handle) do
         fclose(handle);
       done
       return open_log(l);
    else
      return handle;
    done
  }

  proc fsize_: string*&size = """
    {struct stat st;
     stat($1.c_str(), &st);
     *$2 = st.st_size;}
  """;

  gen fsize(name:string):size = {
    var sz:size;
    fsize_(name,&sz);
    return sz;
  }
}
//[simple_config.flx]
publish """
Simple config file reader. Splits key value pairs seperated by the equals character.
Skips lines where first non-space character is the # character. Max configuration file size
is 65535 bytes

Example input:
  # Sample configuration file
  delay         =    0.05
  port          =    1234
  document_root =  ./html

Example code:
  open SimpleConfig;
  if System::argc > 0 do
    var arg = System::argv 1;
    println$ "config file:" + arg;
    iter (proc (kv:string*string) { println(kv.(0)+":"+kv.(1)); })
         (read_config(System::argv 1));
  else
    println("No config file specified");
  done
"""

class SimpleConfig {
  requires header '#include <sys/stat.h>';
  open Assoc_list;
  open Csv;

  typedef configuration = assoc_list[string,string];

  publish """
  Reads configuration file and returns associative list
  """
  fun read_config(config_file:string):configuration = {
    val fsz =  fsize(config_file);
    var config = Empty[string^2];
    if fsz > size(0) and fsz < size(65535) do
      val handle = fopen_input config_file;
      if valid handle do
        val config_text = load(handle);
        fclose(handle);
        println$ "Loaded config file " + config_file;
        config = config + read_config_text(config_text);
      done
    done
    return config;
  }

  fun read_config_text(config_text:string):configuration ={
    print$ "[Config Data]\n" + config_text+"[End Config Data]\n";
    var config = Cons(('INSTALL_ROOT',#Config::std_config.FLX_SHARE_DIR.[to -6]),
                      Empty[string^2]);
    iter (proc (line:string) {config = config + xparse(line);})
             (split(str(config_text),"\n"));
    return apply_param_vars(config);
  }


  publish """
    returns opt param value for given key
  """
  fun get_param(params:list[string*string],name:string) =>
     find (fun (a:string,b:string) => eq(a,b)) params name;

  publish """
    return list strings from comma seperated parameter value
  """
  fun get_param_list(params:list[string*string],name:string) =>
    match get_param(params,name) with |Some v => get_csv_values(v) |_ => Empty[string] endmatch;

  publish """
     Supports $variables in config files. Uses previously defined paramater keys
     as $ variables. Only supports first occurance of $variable. Also
     $INSTALL_ROOT is available nad populated with the value for the felix
     install root
  """
  fun apply_param_vars (par:list[string*string]):list[string*string] ={
    var kp:string = ""; var vp:string = "";
    return map (fun (k:string,v:string) = {
      kp = k; vp = v;
      iter (proc (k1:string,v1:string) {
        kp,vp = match find(vp,k1) with
          |Some p => (kp, substring(vp,0,(p - 1)) + v1 +
                          substring(vp,p+int(k1.len),vp.len))
          |_ => (kp,vp)
        endmatch;
      }) par;
      return (kp,vp);
    }) par;
  }

  fun apply_param_vars_to (par:list[string*string],v:string):string ={
    var vp:string;
    vp = v;
    iter (proc (k1:string,v1:string) {
      vp = match find(vp,k1) with
          |Some p => substring(vp,0,(p - 1)) + v1 +
                      substring(vp,p+int(k1.len),vp.len)
          |_ => vp
        endmatch;
      }) par;
      return vp;
  }

  fun apply_param_vars_to (par:list[string*string],l:list[string]):list[string] =>
    (map (fun (s:string) => apply_param_vars_to (par,s)) (l));

  private fun xparse(line:string):list[string*string] =>
    if startswith (strip line) (char '#') then
      Empty[string*string]
    else
      match split_first(line, "=") with
        |Some s => list[string*string]((strip(s.(0)),strip(s.(1))))
        |None => Empty[string*string]
      endmatch
    endif;

  private fun split_first (x:string, c:string): opt[string*string] ={
    return match find_first_of (x, c) with
      | #None => None[string*string]
      | Some n => Some(strip(x.[to n]),strip(x.[n+1 to]))
      endmatch
    ;
  }

  private proc fsize_: string*&size = """
    {struct stat st;
     stat($1.c_str(), &st);
     *$2 = st.st_size;}
  """;

  private gen fsize(name:string):size = {
    var sz:size;
    fsize_(name,&sz);
    return sz;
  }
}
//[server_config.flx]
include "web/__init__";

class ServerConfig {
  open HTTPHandler;
  open Logger;
  open SimpleConfig;
  open Assoc_list;

  struct server_config {
        delay : double;
        port : int;
        server_root : string;
        document_root : string;
        handlers: list[http_handler];
        log:log_message->void;
        params:list[string*string];
        file_name:string;
        application:string;
  };



  ctor server_config(handlers:list[http_handler]) =>
    server_config(0.05,8080,".","./html",handlers,
    logger(console_logger(INFO)+console_logger(ERROR)),Empty[string*string],"","");

  ctor server_config(handlers:list[http_handler],app:string) =>
    server_config(0.05,8080,".","./html",handlers,
    logger(console_logger(INFO)+console_logger(ERROR)),Empty[string*string],"",app);


  fun basic_server_config(handlers:list[http_handler]):server_config = {
    var cfg = server_config(handlers);
    match enhance_with_config_file(
     enhance_with_command_line_arguments(cfg)) with
    |Some(cfg),_ => return cfg;
    |None,m => return cfg;
    endmatch;

  }

  fun basic_server_config(handlers:list[http_handler],application:string,default_config:string):server_config = {
    var config = server_config(handlers,application);
    match enhance_with_config_file(
      enhance_with_command_line_arguments(config)) with
    |Some(cfg),_ => return cfg;
    |None,m =>  set_params(&config,read_config_text(default_config));
                 return config;
    endmatch;

 }

  fun enhance_with_command_line_arguments(var config:server_config):server_config = {
    var cfg:server_config = config;
    var arg = "";
    var argno = 1;
    while argno<System::argc do
      arg = System::argv argno;
      println$ "ARG=" + arg;
      if prefix(arg,"--document_root=") do
        cfg&.document_root <- arg.[16 to];
      elif prefix(arg,"--server_root=") do
        cfg&.server_root <- arg.[14 to];
      elif prefix(arg,"--port=") do
        cfg&.port <- atoi arg.[7 to];
      elif prefix(arg,"--config=") do
        cfg&.file_name <- arg.[9 to];
        if( not (FileStat::fileexists(cfg.file_name))) do
          proc_fail("unable to open config file:"+cfg.file_name);
        done
      elif prefix(arg,"--debug") do
        var dbg_log:list[log_handler];
        if prefix(arg,"--debug=") do
          val file:string =  str(arg.[8 to]);
          dbg_log = simple_logger(Logger::log("log",file,size(0),0ui),DEBUG);
        else
          dbg_log = console_logger(DEBUG);
        done;
        cfg&.log <- logger(console_logger(INFO)+console_logger(ERROR)+dbg_log);
      elif prefix(arg,"--help") do
        println("Usage: "+(System::argv 0)+""" [OPTION]
  --document-root=PATH    Path to document root directory defaults to ./html
  --server-root=PATH      Path to server root direcory defaults to cwd
  --port=PORT             Port to listen on
  --debug                 Logs DEBUG messages to STDOUT
  --debug=FILE            Logs DEBUG to log/FILE
""");
        System::exit(0);
      done
      ++argno;
    done
    return (cfg);
  }

  private fun tolower: char->char = "(char)::std::tolower($1)" requires Cxx_headers::cctype ;
  private fun toupper: char->char = "(char)::std::toupper($1)" requires Cxx_headers::cctype ;


  fun enhance_with_config_file(var config:server_config):opt[server_config]*string = {
    var cfg = config;
    val config_file_default = Filename::join("config","server_config.cfg");
    val enviro_config = Env::getenv((map toupper cfg.application)+"_CFG","");
    if cfg.file_name == "" do
        if enviro_config  == "" do
            var cwd_config = Filename::join(".",config_file_default);
            if FileStat::fileexists(cwd_config) do
                cfg&.file_name <- cwd_config;
            else
                var home = Env::getenv("HOME","");
                if home == "" do
                   return None[server_config],"Unable to open configuration file HOME environment variable undefined.";
                else
                    var home_config = Filename::join(home,
                    Filename::join(".felix",Filename::join(cfg.application,config_file_default)));
                    if FileStat::fileexists(home_config) do
                        cfg&.file_name <- home_config;
                    else
                        return None[server_config],("Unable to open configurationfile:" + home_config);
                    done
                done
            done
        else
            if FileStat::fileexists(enviro_config) do
                cfg&.file_name <- enviro_config;
            else
                return None[server_config],("Unable to open configurationfile:" + enviro_config);
            done
        done
    else
        if not(FileStat::fileexists(cfg.file_name)) do
            return None[server_config], ("Unable to open configurationfile:" + cfg.file_name);
        done
    done
    set_params(&cfg,read_config(cfg.file_name));
    return Some(cfg),("Configuration file " + cfg.file_name + " read.");
  }

  proc set_params(cfg:&server_config,params:list[string^2]) {
    cfg.params <- params;
    match find (fun (a:string,b:string) => eq(a,b)) params "port" with
      |Some s => cfg.port <- int(s);
      |_ => {}();
    endmatch;
    match find (fun (a:string,b:string) => eq(a,b)) params "server_root" with
      |Some s => cfg.server_root <- s;
      |_ => {}();
    endmatch;
    match find (fun (a:string,b:string) => eq(a,b)) params "document_root" with
      |Some s => cfg.document_root <- s;
      |_ => {}();
    endmatch;
    match find (fun (a:string,b:string) => eq(a,b)) params "delay" with
      |Some s => cfg.delay <- double(s);
      |_ => {}();
    endmatch;

  }

  fun strtod: string -> double = "strtod($1.data(),0)";


  instance Str[server_config] {
    fun str (cfg : server_config):string =>
       "Config file:" + cfg.file_name "\n" +
       (fold_left (fun(i:string) (c:string^2):string =>
         (i + c.(0) + " = " + c.(1) + "\n") ) "" (cfg.params));
  }

}
//[sundown.flx]
//$ A Markdown to Html translator.
class SunDown
{
  fun sundown: string -> string requires package "sundown";
}
//[web_server.flx]
publish """
Accepts connection and spawns fthread to handle request
See webapp.flx for usage example
"""

if PLAT_POSIX do
PosixSignal::ignore_signal(PosixSignal::SIGPIPE);
done

open Socket;
open IOStream;

open TerminalIByteStream[fd_t];
open TerminalIOByteStream[socket_t];


// this is a hack to make close work on a listenter
// RF got this right the first time:
// in the abstract a listener is NOT a socket
// In fact, it is a socket server, with accept() a way to
// read new sockets off it ..
open TerminalIByteStream[socket_t];

requires header '#include <stdlib.h>';

class WebServer {
  open ServerConfig;
  open HTTPRequest;
  open HTTPConnection;
  open MIMEType;
  open Eq[mime_type];
  open Assoc_list;
  open HTTPHandler;
  open Logger;

  proc serve(conn:http_connection, request: http_request)
  {
    val s = conn.sock;
    iter (proc (handler:http_handler) {
      if not *conn.dirty  do
        if handler.handles(conn.config,request) do
          handler.handler_fn(conn,request);
        done
      else
        goto finished;
      done
      }) conn.config.handlers;
    finished:>
    return;
  }

  proc start_webserver(config:server_config) {
    val webby_port = config.port;
    config.log(INFO, "Server started, listenting on "+str config.port);
    // up the queue len for stress testing
    var p = webby_port;
    var listener: socket_t;
    mk_listener(&listener, &p, 10);
    var clock = Faio::mk_alarm_clock();
    // noinline is necessary to stop the closure being
    // inlined into the loop, preventing the socket variable k
    // being duplicated as it must be [a bug in Felix]
    noinline proc handler (var k:socket_t) ()
    {
      config.log(DEBUG,"Spawned fthread running for socket "+str k);
      // should spawn fthread here to allow for more io overlap
      val conn = http_connection(config ,k);
      var request:http_request;
      open HTTPRequest;
      open  Eq[http_method];
      open MIMEType;
      HTTPRequest::get_request(conn,&request);
       Faio::sleep(clock,config.delay);
      /*Get entity form parameters if method is post and
        content type is application/x-www-form-urlencoded */
      //if str(request.hmethod) == str(POST) do
      match get_header(request,"Content-Type") with
        | Some c => {
          match parse_media_type(c) with
            | Some (m,a) => {
              if str(m) == str(application x_DASH_www_DASH_form_DASH_urlencoded) do
                HTTPRequest::get_entity_params(conn,&request,a);
              elif str(m) == str(form-data) do
                HTTPRequest::get_multipart_params(conn,&request,a);
              else
                request.entity_params=Empty[string*string];
              done
              }
            |_ =>  { request.entity_params=Empty[string*string]; }
          endmatch; }
        |_ => { request.entity_params=Empty[string*string]; }
      endmatch;
      serve(conn,request);
      Faio::sleep(clock,config.delay); // give OS time to empty its buffers
      // try this:
      // Advised by: koettermarkus@gmx.de, MANY THANKS!

      gen hack_recv: socket_t * &char * int * int -> int = "recv($1,$2,$3,$4)";

      var buf:char ^1025;
      var counter = 0;
      var extra = 0;
      shutdown(k,1); // shutdown write
      retry:>
        var b = hack_recv(k,C_hack::cast[&char] (&buf),1024,0);
        //println$ "Error code " + str b + " from read after shutdown";
        if b > 0 do
          extra += b;
          if extra > 2000 do
            config.log(WARNING,"Read too many extraneous bytes from OS buffer");
            goto force_close;
          done;
          goto retry;
        elif b == -1 do
        ++counter;
        if counter > 200 do
          config.log(WARNING,"Timeout waiting for write buffers to be flushed");
          goto force_close;
        done;
        Faio::sleep(clock,0.1); // 100 ms
        goto retry;
      done;
      assert b==0;

      force_close:>
      Socket::shutdown(k,2);
      ioclose(k);

    };

    noinline proc stuff {
      var s: socket_t;
      config.log(DEBUG,"Waiting for connection");
      accept(listener, &s);  // blocking
      config.log(DEBUG,"got connection "+str s);  // error check here

      //  - spawning an fthread is blocking the web server. don't know why
      config.log(DEBUG,"spawning fthread to handle connection "+str s);
      spawn_fthread$  handler s;
      collect(); // this hangs everything, no idea why!
    };
    while true do stuff; done

    config.log(INFO,"WEB SERVER SHUTDOWN");
    iclose (listener);
  }

}