summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/openssl.c40
-rw-r--r--src/c/static.c2
-rw-r--r--src/c/urweb.c5
-rw-r--r--src/core_util.sml22
-rw-r--r--src/monoize.sml15
-rw-r--r--src/urweb.grm1
-rw-r--r--src/urweb.lex26
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-12 15:32:22 +0000