diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/c/openssl.c | 40 | ||||
-rw-r--r-- | src/c/static.c | 2 | ||||
-rw-r--r-- | src/c/urweb.c | 5 | ||||
-rw-r--r-- | src/core_util.sml | 22 | ||||
-rw-r--r-- | src/monoize.sml | 15 | ||||
-rw-r--r-- | src/urweb.grm | 1 | ||||
-rw-r--r-- | src/urweb.lex | 26 |
7 files changed, 88 insertions, 23 deletions
diff --git a/src/c/openssl.c b/src/c/openssl.c index 1d820a34..6d018707 100644 --- a/src/c/openssl.c +++ b/src/c/openssl.c @@ -1,5 +1,6 @@ #include "config.h" +#include <assert.h> #include <stdlib.h> #include <unistd.h> #include <sys/types.h> @@ -7,12 +8,17 @@ #include <fcntl.h> #include <stdio.h> #include <string.h> +#include <pthread.h> +#include <openssl/crypto.h> #include <openssl/sha.h> #include <openssl/rand.h> #define PASSSIZE 4 +// OpenSSL locks array. See threads(3SSL). +static pthread_mutex_t *openssl_locks; + int uw_hash_blocksize = 32; static int password[PASSSIZE]; @@ -27,7 +33,41 @@ static void random_password() { } } +// OpenSSL callbacks +static void thread_id(CRYPTO_THREADID *const result) { + CRYPTO_THREADID_set_numeric(result, pthread_self()); +} +static void lock_or_unlock(const int mode, const int type, const char *file, + const int line) { + pthread_mutex_t *const lock = &openssl_locks[type]; + if (mode & CRYPTO_LOCK) { + if (pthread_mutex_lock(lock)) { + fprintf(stderr, "Can't take lock at %s:%d\n", file, line); + exit(1); + } + } else { + if (pthread_mutex_unlock(lock)) { + fprintf(stderr, "Can't release lock at %s:%d\n", file, line); + exit(1); + } + } +} + void uw_init_crypto() { + int i; + // Set up OpenSSL. + assert(openssl_locks == NULL); + openssl_locks = malloc(CRYPTO_num_locks() * sizeof(pthread_mutex_t)); + if (!openssl_locks) { + perror("malloc"); + exit(1); + } + for (i = 0; i < CRYPTO_num_locks(); ++i) { + pthread_mutex_init(&(openssl_locks[i]), NULL); + } + CRYPTO_THREADID_set_callback(thread_id); + CRYPTO_set_locking_callback(lock_or_unlock); + // Prepare signatures. if (uw_sig_file) { int fd; diff --git a/src/c/static.c b/src/c/static.c index c8fd5bc7..7f63d393 100644 --- a/src/c/static.c +++ b/src/c/static.c @@ -37,7 +37,7 @@ int main(int argc, char *argv[]) { while (1) { fk = uw_begin(ctx, argv[1]); - if (fk == SUCCESS) { + if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { uw_print(ctx, 1); puts(""); return 0; diff --git a/src/c/urweb.c b/src/c/urweb.c index 1e49dae0..6d3836f1 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -167,13 +167,8 @@ void *uw_init_client_data(); void uw_free_client_data(void *); void uw_copy_client_data(void *dst, void *src); -static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; - static uw_Basis_int my_rand() { - pthread_mutex_lock(&rand_mutex); int ret, r = RAND_bytes((unsigned char *)&ret, sizeof ret); - pthread_mutex_unlock(&rand_mutex); - if (r) return abs(ret); else diff --git a/src/core_util.sml b/src/core_util.sml index 152ba7ac..9ca85c37 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -203,7 +203,7 @@ fun compare ((c1, _), (c2, _)) = | (_, CConcat _) => GREATER | (CMap (d1, r1), CMap (d2, r2)) => - join (Kind.compare (d1, r2), + join (Kind.compare (d1, d2), fn () => Kind.compare (r1, r2)) | (CMap _, _) => LESS | (_, CMap _) => GREATER @@ -607,15 +607,19 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = | ERel _ => S.return2 eAll | ENamed _ => S.return2 eAll | ECon (dk, pc, cs, NONE) => - S.map2 (ListUtil.mapfold (mfc ctx) cs, - fn cs' => - (ECon (dk, pc, cs', NONE), loc)) - | ECon (dk, n, cs, SOME e) => - S.bind2 (mfe ctx e, - fn e' => + S.bind2 (mfpc ctx pc, + fn pc' => S.map2 (ListUtil.mapfold (mfc ctx) cs, - fn cs' => - (ECon (dk, n, cs', SOME e'), loc))) + fn cs' => + (ECon (dk, pc', cs', NONE), loc))) + | ECon (dk, pc, cs, SOME e) => + S.bind2 (mfpc ctx pc, + fn pc' => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (ListUtil.mapfold (mfc ctx) cs, + fn cs' => + (ECon (dk, pc', cs', SOME e'), loc)))) | EFfi _ => S.return2 eAll | EFfiApp (m, x, es) => S.map2 (ListUtil.mapfold (mfet ctx) es, diff --git a/src/monoize.sml b/src/monoize.sml index bac82f55..8934db2c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2214,6 +2214,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val t = monoType env t val s = (L'.TFfi ("Basis", "string"), loc) + + fun toSqlType (t : L'.typ) = + case #1 t of + L'.TFfi ("Basis", "int") => Settings.Int + | L'.TFfi ("Basis", "float") => Settings.Float + | L'.TFfi ("Basis", "string") => Settings.String + | L'.TFfi ("Basis", "char") => Settings.Char + | L'.TFfi ("Basis", "bool") => Settings.Bool + | L'.TFfi ("Basis", "time") => Settings.Time + | L'.TFfi ("Basis", "blob") => Settings.Blob + | L'.TFfi ("Basis", "channel") => Settings.Channel + | L'.TFfi ("Basis", "client") => Settings.Client + | _ => raise Fail "Monoize/sql_option_prim: invalid SQL type" in ((L'.EAbs ("f", (L'.TFun (t, s), loc), @@ -2223,7 +2236,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = s, (L'.ECase ((L'.ERel 0, loc), [((L'.PNone t, loc), - str "NULL"), + str (#p_cast (Settings.currentDbms ()) ("NULL", toSqlType t))), ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc), (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))], {disc = (L'.TOption t, loc), diff --git a/src/urweb.grm b/src/urweb.grm index 7fc34793..50dacf21 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1624,6 +1624,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) val e = (EVar (["Basis"], "form", Infer), pos) val e = (EApp (e, case #2 tag of NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME (EPrim (Prim.String (_, s)), _) => (EApp ((EVar (["Basis"], "Some", Infer), pos), parseClass s pos), pos) | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos) in case #3 tag of diff --git a/src/urweb.lex b/src/urweb.lex index e1ffd1c3..f32ddf1e 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -178,11 +178,11 @@ fun unescape loc s = id = [a-z_][A-Za-z0-9_']*; xmlid = [A-Za-z][A-Za-z0-9_-]*; -cid = [A-Z][A-Za-z0-9_]*; +cid = [A-Z][A-Za-z0-9_']*; ws = [\ \t\012\r]; intconst = [0-9]+; realconst = [0-9]+\.[0-9]*; -hexconst = 0x[0-9A-F]{1,8}; +hexconst = 0x[0-9A-F]+; notags = ([^<{\n(]|(\([^\*<{\n]))+; xcom = ([^\-]|(-[^\-]))+; oint = [0-9][0-9][0-9]; @@ -537,22 +537,34 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); -<INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); +<INITIAL> "_LOC_" => (let val strLoc = ErrorMsg.spanToString (ErrorMsg.spanOf + (pos yypos, pos yypos + size yytext)) + in + Tokens.STRING (strLoc, pos yypos, pos yypos + size yytext) + end); <INITIAL> {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); <INITIAL> {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); -<INITIAL> {hexconst} => (case StringCvt.scanString (Int64.scan StringCvt.HEX) (String.extract (yytext, 2, NONE)) of +<INITIAL> {hexconst} => (let val digits = String.extract (yytext, 2, NONE) + val v = (StringCvt.scanString (Int64.scan StringCvt.HEX) digits) + handle Overflow => NONE + in + case v of SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) ("Expected hexInt, received: " ^ yytext); - continue ())); + continue ()) + end); -<INITIAL> {intconst} => (case Int64.fromString yytext of +<INITIAL> {intconst} => (let val v = (Int64.fromString yytext) handle Overflow => NONE + in + case v of SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) ("Expected int, received: " ^ yytext); - continue ())); + continue ()) + end); <INITIAL> {realconst} => (case Real64.fromString yytext of SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext) | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) |