/**
serialize : any -> string
<doc>Serialize any value recursively</doc>
**/
static value serialize( value o ) {
sbuffer b;
value v;
char *s;
strlist *l;
b.olds = NULL;
b.refs = NULL;
b.nrefs = 0;
b.cur = (unsigned char*)alloc_private(BUF_SIZE);
b.size = BUF_SIZE;
b.pos = 0;
b.totlen = 0;
b.nrec = 0;
serialize_rec(&b,o);
v = alloc_empty_string(b.pos + b.totlen);
s = (char*)val_string(v);
s += b.totlen;
l = b.olds;
memcpy(s,b.cur,b.pos);
while( l != NULL ) {
s -= l->slen;
memcpy(s,l->str,l->slen);
l = l->next;
}
return v;
}
static value dgst_sign(value data, value key, value alg){
const mbedtls_md_info_t *md;
int r = -1;
size_t olen = 0;
value out;
unsigned char *buf;
unsigned char hash[32];
val_check(data, string);
val_check_kind(key, k_pkey);
val_check(alg, string);
md = mbedtls_md_info_from_string(val_string(alg));
if( md == NULL ){
val_throw(alloc_string("Invalid hash algorithm"));
return val_null;
}
if( (r = mbedtls_md( md, (const unsigned char *)val_string(data), val_strlen(data), hash )) != 0 )
return ssl_error(r);
out = alloc_empty_string(MBEDTLS_MPI_MAX_SIZE);
buf = (unsigned char *)val_string(out);
if( (r = mbedtls_pk_sign( val_pkey(key), mbedtls_md_get_type(md), hash, 0, buf, &olen, mbedtls_ctr_drbg_random, &ctr_drbg )) != 0 )
return ssl_error(r);
buf[olen] = 0;
val_set_size(out, olen);
return out;
}
/**
$smake : n:int -> string
<doc>Return an uninitialized string of size [n]</doc>
**/
static value builtin_smake( value l ) {
value v;
val_check(l,int);
v = alloc_empty_string( val_int(l) );
memset(val_string(v),0,val_int(l));
return v;
}
/**
file_contents : f:string -> string
<doc>Read the content of the file [f] and return it.</doc>
**/
static value file_contents( value name ) {
value s;
fio f;
int len;
int p;
val_check(name,string);
f.name = name;
f.io = fopen(val_string(name),"rb");
if( f.io == NULL )
file_error("file_contents",&f);
fseek(f.io,0,SEEK_END);
len = ftell(f.io);
fseek(f.io,0,SEEK_SET);
s = alloc_empty_string(len);
p = 0;
while( len > 0 ) {
int d;
POSIX_LABEL(file_contents);
d = (int)fread((char*)val_string(s)+p,1,len,f.io);
if( d <= 0 ) {
HANDLE_FINTR(f.io,file_contents);
fclose(f.io);
file_error("file_contents",&f);
}
p += d;
len -= d;
}
fclose(f.io);
return s;
}
/**
sys_env : void -> #list
<doc>Return all the (key,value) pairs in the environment as a chained list</doc>
**/
static value sys_env() {
value h = val_null;
value cur = NULL, tmp, key;
char **e = environ;
while( *e ) {
char *x = strchr(*e,'=');
if( x == NULL ) {
e++;
continue;
}
tmp = alloc_array(3);
key = alloc_empty_string((int)(x - *e));
memcpy(val_string(key),*e,(int)(x - *e));
val_array_ptr(tmp)[0] = key;
val_array_ptr(tmp)[1] = alloc_string(x+1);
val_array_ptr(tmp)[2] = val_null;
if( cur )
val_array_ptr(cur)[2] = tmp;
else
h = tmp;
cur = tmp;
e++;
}
return h;
}
value neko_append_strings( value s1, value s2 ) {
int len1 = val_strlen(s1);
int len2 = val_strlen(s2);
value v = alloc_empty_string(len1+len2);
memcpy((char*)val_string(v),val_string(s1),len1);
memcpy((char*)val_string(v)+len1,val_string(s2),len2+1);
return v;
}
/**
result_next : 'result -> object?
<doc>Returns the next row in the result or [null] if no more result.</doc>
**/
static value result_next( value v ) {
int i;
result *r;
val_check_kind(v,k_result);
r = val_result(v);
if( r->done )
return val_null;
switch( sqlite3_step(r->r) ) {
case SQLITE_ROW:
r->first = 0;
v = alloc_object(NULL);
for(i=0;i<r->ncols;i++) {
value f;
switch( sqlite3_column_type(r->r,i) ) {
case SQLITE_NULL:
f = val_null;
break;
case SQLITE_INTEGER:
if( r->bools[i] )
f = alloc_bool(sqlite3_column_int(r->r,i));
else
f = alloc_int(sqlite3_column_int(r->r,i));
break;
case SQLITE_FLOAT:
f = alloc_float(sqlite3_column_double(r->r,i));
break;
case SQLITE_TEXT:
f = alloc_string((char*)sqlite3_column_text(r->r,i));
break;
case SQLITE_BLOB:
{
int size = sqlite3_column_bytes(r->r,i);
f = alloc_empty_string(size);
memcpy(val_string(f),sqlite3_column_blob(r->r,i),size);
break;
}
default:
{
buffer b = alloc_buffer("Unknown Sqlite type #");
val_buffer(b,alloc_int(sqlite3_column_type(r->r,i)));
val_throw(buffer_to_string(b));
}
}
alloc_field(v,r->names[i],f);
}
return v;
case SQLITE_DONE:
finalize_result(r,1);
return val_null;
case SQLITE_BUSY:
val_throw(alloc_string("Database is busy"));
case SQLITE_ERROR:
sqlite_error(r->db->db);
default:
neko_error();
}
return val_null;
}
/**
escape : 'connection -> string -> string
<doc>Escape the string for inserting into a SQL request</doc>
**/
static value escape( value o, value s ) {
int len;
value sout;
val_check_kind(o,k_connection);
val_check(s,string);
len = val_strlen(s) * 2;
sout = alloc_empty_string(len);
len = mysql_real_escape_string(CNX(o)->m,val_string(sout),val_string(s),val_strlen(s));
val_set_length(sout,len);
return sout;
}
EXTERN value buffer_to_string( buffer b ) {
value v = alloc_empty_string(b->totlen);
stringitem it = b->data;
char *s = (char*)val_string(v) + b->totlen;
while( it != NULL ) {
stringitem tmp;
s -= it->len;
memcpy(s,it->str,it->len);
tmp = it->next;
it = tmp;
}
return v;
}
static value asn1_buf_to_string( mbedtls_asn1_buf *dat ){
unsigned int i, c;
char *b;
value buf = alloc_empty_string( dat->len );
b = val_string(buf);
for( i = 0; i < dat->len; i++ ) {
c = dat->p[i];
if( c < 32 || c == 127 || ( c > 128 && c < 160 ) )
b[i] = '?';
else
b[i] = c;
}
return buf;
}
/**
module_read : fread:(buf:string -> pos:int -> len:int -> int) -> loader:object -> 'module
<doc>
Read a module using the specified read function and the specified loader.
</doc>
**/
static value module_read( value fread, value loader ) {
value p;
neko_module *m;
val_check_function(fread,3);
val_check(loader,object);
p = alloc_array(2);
val_array_ptr(p)[0] = fread;
val_array_ptr(p)[1] = alloc_empty_string(READ_BUFSIZE);
m = neko_read_module(read_proxy,p,loader);
if( m == NULL )
neko_error();
m->name = alloc_string("");
return alloc_abstract(neko_kind_module,m);
}
value neko_append_int( neko_vm *vm, value str, int x, bool way ) {
int len, len2;
value v;
len = val_strlen(str);
len2 = sprintf(vm->tmp,"%d",x);
v = alloc_empty_string(len+len2);
if( way ) {
memcpy((char*)val_string(v),val_string(str),len);
memcpy((char*)val_string(v)+len,vm->tmp,len2+1);
} else {
memcpy((char*)val_string(v),vm->tmp,len2);
memcpy((char*)val_string(v)+len2,val_string(str),len+1);
}
return v;
}
/**
escape : 'connection -> string -> string
<doc>Escape the string for inserting into a SQL request</doc>
**/
static value escape( value o, value s ) {
int len;
value sout;
val_check_kind(o,k_connection);
val_check(s,string);
len = val_strlen(s) * 2;
sout = alloc_empty_string(len);
len = mysql_real_escape_string(CNX(o)->m,val_string(sout),val_string(s),val_strlen(s));
if( len < 0 ) {
buffer b = alloc_buffer("Unsupported charset : ");
buffer_append(b,mysql_character_set_name(CNX(o)->m));
bfailure(b);
}
val_set_length(sout,len);
val_string(sout)[len] = 0;
return sout;
}
static int read_proxy( readp p, void *buf, int size ) {
value fread = val_array_ptr(p)[0];
value vbuf = val_array_ptr(p)[1];
value ret;
int len;
if( size < 0 )
return -1;
if( size > READ_BUFSIZE )
vbuf = alloc_empty_string(size);
ret = val_call3(fread,vbuf,alloc_int(0),alloc_int(size));
if( !val_is_int(ret) )
return -1;
len = val_int(ret);
if( len < 0 || len > size )
return -1;
memcpy(buf,val_string(vbuf),len);
return len;
}
static value dgst_make(value data, value alg){
const mbedtls_md_info_t *md;
int r = -1;
value out;
val_check(data, string);
val_check(alg, string);
md = mbedtls_md_info_from_string(val_string(alg));
if( md == NULL ){
val_throw(alloc_string("Invalid hash algorithm"));
return val_null;
}
out = alloc_empty_string( mbedtls_md_get_size(md) );
if( (r = mbedtls_md( md, (const unsigned char *)val_string(data), val_strlen(data), (unsigned char *)val_string(out) )) != 0 )
return ssl_error(r);
return out;
}
/**
regexp_matched : 'regexp -> n:int -> string?
<doc>Return the [n]th matched block by the regexp. If [n] is 0 then return
the whole matched substring. If the [n]th matched block was optional and not matched, returns null</doc>
**/
static value regexp_matched( value o, value n ) {
pcredata *d;
int m;
val_check_kind(o,k_regexp);
d = PCRE(o);
val_check(n,int);
m = val_int(n);
if( m < 0 || m >= d->nmatchs || val_is_null(d->str) )
neko_error();
{
int start = d->matchs[m*2];
int len = d->matchs[m*2+1] - start;
value str;
if( start == -1 )
return val_null;
str = alloc_empty_string(len);
memcpy((char*)val_string(str),val_string(d->str)+start,len);
return str;
}
}
static value url_decode( const char *in, int len ) {
int pin = 0;
int pout = 0;
value v = alloc_empty_string(len);
char *out = (char*)val_string(v);
while( len-- > 0 ) {
char c = in[pin++];
if( c == '+' )
c = ' ';
else if( c == '%' ) {
int p1, p2;
if( len < 2 )
break;
p1 = in[pin++];
p2 = in[pin++];
len -= 2;
if( p1 >= '0' && p1 <= '9' )
p1 -= '0';
else if( p1 >= 'a' && p1 <= 'f' )
p1 -= 'a' - 10;
else if( p1 >= 'A' && p1 <= 'F' )
p1 -= 'A' - 10;
else
continue;
if( p2 >= '0' && p2 <= '9' )
p2 -= '0';
else if( p2 >= 'a' && p2 <= 'f' )
p2 -= 'a' - 10;
else if( p2 >= 'A' && p2 <= 'F' )
p2 -= 'A' - 10;
else
continue;
c = (char)((unsigned char)((p1 << 4) + p2));
}
out[pout++] = c;
}
out[pout] = 0;
val_set_size(v,pout);
return v;
}
EXTERN value copy_string( const char *str, int_val strlen ) {
value v = alloc_empty_string((unsigned int)strlen);
char *c = (char*)val_string(v);
memcpy(c,str,strlen);
return v;
}
static value unserialize_rec( sbuffer *b, value loader ) {
switch( read_char(b) ) {
case 'N':
return val_null;
case 'T':
return val_true;
case 'F':
return val_false;
case 'i':
return alloc_int(read_int(b));
case 'I':
return alloc_int32(read_int(b));
case 'f':
{
tfloat d;
read_str(b,sizeof(tfloat),&d);
return alloc_float(d);
}
case 's':
{
int l = read_int(b);
value v;
if( l < 0 || l > max_string_size )
ERROR();
v = alloc_empty_string(l);
add_ref(b,v);
read_str(b,l,(char*)val_string(v));
return v;
}
case 'o':
{
int f;
value o = alloc_object(NULL);
add_ref(b,o);
while( (f = read_int(b)) != 0 ) {
value fval = unserialize_rec(b,loader);
alloc_field(o,(field)f,fval);
}
switch( read_char(b) ) {
case 'p':
{
value v = unserialize_rec(b,loader);
if( !val_is_object(v) )
ERROR();
((vobject*)o)->proto = (vobject*)v;
}
break;
case 'z':
break;
default:
ERROR();
}
return o;
}
case 'r':
{
int n = read_int(b);
if( n < 0 || n >= b->nrefs )
ERROR();
return b->trefs[b->nrefs - n - 1];
}
case 'a':
{
int i;
int n = read_int(b);
value o;
value *t;
if( n < 0 || n > max_array_size )
ERROR();
o = alloc_array(n);
t = val_array_ptr(o);
add_ref(b,o);
for(i=0;i<n;i++)
t[i] = unserialize_rec(b,loader);
return o;
}
case 'p':
{
int nargs = read_int(b);
vfunction *f = (vfunction*)alloc_function((void*)1,nargs,NULL);
vfunction *f2;
value name;
add_ref(b,(value)f);
name = unserialize_rec(b,loader);
f2 = (vfunction*)val_ocall2(loader,id_loadprim,name,alloc_int(nargs));
if( !val_is_function(f2) || val_fun_nargs(f2) != nargs )
failure("Loader returned not-a-function");
f->t = f2->t;
f->addr = f2->addr;
f->module = f2->module;
return (value)f;
}
case 'L':
{
vfunction *f = (vfunction*)alloc_function((void*)1,0,NULL);
value mname;
int pos;
int nargs;
value env;
add_ref(b,(value)f);
mname = unserialize_rec(b,loader);
pos = read_int(b);
nargs = read_int(b);
env = unserialize_rec(b,loader);
if( !val_is_array(env) )
ERROR();
{
value exp = val_ocall2(loader,id_loadmodule,mname,loader);
value mval;
unsigned int i;
int_val *mpos;
neko_module *m;
if( !val_is_object(exp) ) {
buffer b = alloc_buffer("module ");
val_buffer(b,mname);
buffer_append(b," is not an object");
bfailure(b);
}
mval = val_field(exp,id_module);
if( !val_is_kind(mval,neko_kind_module) ) {
buffer b = alloc_buffer("module ");
val_buffer(b,mname);
buffer_append(b," has invalid type");
bfailure(b);
}
m = (neko_module*)val_data(mval);
mpos = m->code + pos;
for(i=0;i<m->nglobals;i++) {
vfunction *g = (vfunction*)m->globals[i];
if( val_is_function(g) && g->addr == mpos && g->module == m && g->nargs == nargs ) {
f->t = VAL_FUNCTION;
f->env = env;
f->addr = mpos;
f->nargs = nargs;
f->module = m;
return (value)f;
}
}
{
buffer b = alloc_buffer("module ");
val_buffer(b,mname);
buffer_append(b," has been modified");
bfailure(b);
}
}
return val_null;
}
case 'x':
{
value mname = unserialize_rec(b,loader);
value data = unserialize_rec(b,loader);
value exports = val_ocall2(loader,id_loadmodule,mname,loader);
value s;
if( !val_is_object(exports) ) {
buffer b = alloc_buffer("module ");
val_buffer(b,mname);
buffer_append(b," is not an object");
bfailure(b);
}
s = val_field(exports,id_unserialize);
if( !val_is_function(s) || (val_fun_nargs(s) != 1 && val_fun_nargs(s) != VAR_ARGS) ) {
buffer b = alloc_buffer("module ");
val_buffer(b,mname);
buffer_append(b," has invalid __unserialize function");
}
s = val_call1(s,data);
add_ref(b,s);
return s;
}
case 'h':
{
int i;
vhash *h = (vhash*)alloc(sizeof(vhash));
h->ncells = read_int(b);
h->nitems = read_int(b);
h->cells = (hcell**)alloc(sizeof(hcell*)*h->ncells);
for(i=0;i<h->ncells;i++)
h->cells[i] = NULL;
for(i=0;i<h->nitems;i++) {
hcell **p;
hcell *c = (hcell*)alloc(sizeof(hcell));
c->hkey = read_int(b);
c->key = unserialize_rec(b,loader);
c->val = unserialize_rec(b,loader);
c->next = NULL;
p = &h->cells[c->hkey % h->ncells];
while( *p != NULL )
p = &(*p)->next;
*p = c;
}
return alloc_abstract(k_hash,h);
}
default:
ERROR();
return val_null;
}
}
/**
parse_multipart_data : onpart:function:2 -> ondata:function:3 -> void
<doc>
Incrementally parse the multipart data. call [onpart(name,filename)] for each part
found and [ondata(buf,pos,len)] when some data is available
</doc>
**/
static value parse_multipart_data( value onpart, value ondata ) {
value buf;
int len = 0;
mcontext *c = CONTEXT();
const char *ctype = ap_table_get(c->r->headers_in,"Content-Type");
value boundstr;
val_check_function(onpart,2);
val_check_function(ondata,3);
buf = alloc_empty_string(BUFSIZE);
if( !ctype || strstr(ctype,"multipart/form-data") == NULL )
return val_null;
// extract boundary value
{
const char *boundary, *bend;
if( (boundary = strstr(ctype,"boundary=")) == NULL )
neko_error();
boundary += 9;
PARSE_HEADER(boundary,bend);
len = (int)(bend - boundary);
boundstr = alloc_empty_string(len+2);
if( val_strlen(boundstr) > BUFSIZE / 2 )
neko_error();
val_string(boundstr)[0] = '-';
val_string(boundstr)[1] = '-';
memcpy(val_string(boundstr)+2,boundary,len);
}
len = 0;
if( !ap_should_client_block(c->r) )
neko_error();
while( true ) {
char *name, *end_name, *filename, *end_file_name, *data;
int pos;
// refill buffer
// we assume here that the the whole multipart header can fit in the buffer
fill_buffer(c,buf,&len);
// is boundary at the beginning of buffer ?
if( len < val_strlen(boundstr) || memcmp(val_string(buf),val_string(boundstr),val_strlen(boundstr)) != 0 )
return discard_body(c);
name = memfind(val_string(buf),len,"Content-Disposition:");
if( name == NULL )
break;
name = memfind(name,len - (int)(name - val_string(buf)),"name=");
if( name == NULL )
return discard_body(c);
name += 5;
PARSE_HEADER(name,end_name);
data = memfind(end_name,len - (int)(end_name - val_string(buf)),"\r\n\r\n");
if( data == NULL )
return discard_body(c);
filename = memfind(name,(int)(data - name),"filename=");
if( filename != NULL ) {
filename += 9;
PARSE_HEADER(filename,end_file_name);
}
data += 4;
pos = (int)(data - val_string(buf));
// send part name
val_call2(onpart,copy_string(name,(int)(end_name - name)),filename?copy_string(filename,(int)(end_file_name - filename)):val_null);
// read data
while( true ) {
const char *boundary;
// recall buffer
memmove(val_string(buf),val_string(buf)+pos,len - pos);
len -= pos;
pos = 0;
fill_buffer(c,buf,&len);
// lookup bounds
boundary = memfind(val_string(buf),len,val_string(boundstr));
if( boundary == NULL ) {
if( len == 0 )
return discard_body(c);
// send as much buffer as possible to client
if( len < BUFSIZE )
pos = len;
else
pos = len - val_strlen(boundstr) + 1;
val_call3(ondata,buf,alloc_int(0),alloc_int(pos));
} else {
// send remaining data
pos = (int)(boundary - val_string(buf));
val_call3(ondata,buf,alloc_int(0),alloc_int(pos-2));
// recall
memmove(val_string(buf),val_string(buf)+pos,len - pos);
len -= pos;
break;
}
}
}
return val_null;
}
