[MLton-commit] r5233
Wesley Terpstra
wesley at mlton.org
Sat Feb 17 08:13:04 PST 2007
add support for setting the authorizer
----------------------------------------------------------------------
U mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
U mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
U mltonlib/trunk/ca/terpstra/sqlite3/query.sml
U mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sig
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-17 15:45:18 UTC (rev 5232)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sig 2007-02-17 16:13:04 UTC (rev 5233)
@@ -114,7 +114,8 @@
| CREATE_VTABLE of { table: string, module: string, db: string }
| DROP_VTABLE of { table: string, module: string, db: string }
| FUNCTION of { function: string }
- val setAuthorizer: db * (request -> access) option -> unit
+ val setAuthorizer: db * (request -> access) -> hook
+ val unsetAuthorizer: db -> unit
(* Only do this after closing the database or unbinding the fn *)
val unhook: hook -> unit
Modified: mltonlib/trunk/ca/terpstra/sqlite3/prim.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/prim.sml 2007-02-17 15:45:18 UTC (rev 5232)
+++ mltonlib/trunk/ca/terpstra/sqlite3/prim.sml 2007-02-17 16:13:04 UTC (rev 5233)
@@ -259,7 +259,7 @@
type callback = Context.t * Value.t vector -> unit
- datatype hook = UFN of int | COLL of int | AGGR of int
+ datatype hook = UFN of int | COLL of int | AGGR of int | AUTH of int
(************************************************* Scalar functions *)
val fnt = Buffer.empty ()
fun fnCallback (context, numargs, args) =
@@ -460,11 +460,39 @@
CStr.toStringOpt c)
handle Option => raise Error "SQLite did not provided expected authorization paramater"
- fun setAuthorizer _ = ()
+ val autht = Buffer.empty ()
+ fun authCallback (uarg, code, a, b, c, d) =
+ let
+ val auth = Buffer.sub (autht, Word.toInt uarg)
+ in
+ (case auth (parseRequest (code, a, b, c, d)) of
+ ALLOW => 0
+ | DENY => 1
+ | IGNORE => 2)
+ (* don't propogate an exception up as it will segfault.
+ * do complain somehow that this is bad!
+ *)
+ handle _ => (TextIO.output (TextIO.stdErr,
+ "SML exception raised during authorization! bad!");
+ 1)
+ end
+ val () = _export "mlton_sqlite3_authhook" : (word * int * CStr.out * CStr.out * CStr.out * CStr.out -> int) -> unit;
+ authCallback
+ val authCallbackPtr = _address "mlton_sqlite3_authhook" : FnPtr.t;
+ fun unsetAuthorizer db = code (db, PsetAuthorizer (db, FnPtr.null, 0w0))
+ fun setAuthorizer (db, auth) =
+ let
+ val id = Buffer.push (autht, auth)
+ val r = PsetAuthorizer (db, authCallbackPtr, Word.fromInt id)
+ in
+ code (db, r);
+ AUTH id
+ end
fun unhook (UFN x) = Buffer.free (fnt, x)
| unhook (COLL x) = Buffer.free (colt, x)
| unhook (AGGR x) = Buffer.free (aggen, x)
+ | unhook (AUTH x) = Buffer.free (autht, x)
type db = DB.t
type query = Query.t
Modified: mltonlib/trunk/ca/terpstra/sqlite3/query.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/query.sml 2007-02-17 15:45:18 UTC (rev 5232)
+++ mltonlib/trunk/ca/terpstra/sqlite3/query.sml 2007-02-17 16:13:04 UTC (rev 5233)
@@ -86,7 +86,7 @@
Ring.remove l
)
in
- fun prepare { ring, hooks } qt =
+ fun prepare { ring, hooks=_, auth=_ } qt =
case Ring.get ring of { db, query=_, available=_, used=_ } =>
Fold.fold (([qt], oF0, oN0, oI0, iF0, iN0),
fn (ql, oF, _, oI, iF, _) =>
Modified: mltonlib/trunk/ca/terpstra/sqlite3/sql.sml
===================================================================
--- mltonlib/trunk/ca/terpstra/sqlite3/sql.sml 2007-02-17 15:45:18 UTC (rev 5232)
+++ mltonlib/trunk/ca/terpstra/sqlite3/sql.sml 2007-02-17 16:13:04 UTC (rev 5233)
@@ -1,7 +1,9 @@
structure SQL :> SQL =
struct
type column = Prim.column
- type db = { ring: Query.pool Ring.t, hooks: Prim.hook list ref }
+ type db = { ring: Query.pool Ring.t,
+ hooks: Prim.hook list ref,
+ auth: Prim.hook option ref }
datatype storage = datatype Prim.storage
exception Retry = Prim.Retry
@@ -13,7 +15,7 @@
val version = Prim.version
- fun getDB { ring, hooks=_ } =
+ fun getDB { ring, hooks=_, auth=_ } =
case Ring.get ring of { db, query=_, available=_, used } =>
if !used = ~1 then raise Error "Database closed" else db
@@ -22,9 +24,10 @@
query = "database",
available = ref [],
used = ref 0 },
- hooks = ref [] }
+ hooks = ref [],
+ auth = ref NONE }
- fun closeDB (dbh as { ring, hooks }) =
+ fun closeDB (dbh as { ring, hooks, auth }) =
let
val db = getDB dbh (* raises if closed *)
fun notInUse { db=_, query=_, available=_, used } = !used = 0
@@ -44,7 +47,9 @@
reraise (!exn);
Prim.closeDB db;
List.app Prim.unhook (!hooks);
- hooks := [])
+ hooks := [];
+ Option.app Prim.unhook (!auth);
+ auth := NONE)
else raise Error "Database in use"
end
@@ -131,13 +136,13 @@
end
end
- fun registerFunction (db as { ring=_, hooks }, s, (f, i)) =
+ fun registerFunction (db as { ring=_, hooks, auth=_ }, s, (f, i)) =
hooks := Prim.createFunction (getDB db, s, f, i) :: !hooks
- fun registerAggregate (db as { ring=_, hooks }, s, (a, i)) =
+ fun registerAggregate (db as { ring=_, hooks, auth=_ }, s, (a, i)) =
hooks := Prim.createAggregate (getDB db, s, a, i) :: !hooks
- fun registerCollation (db as { ring=_, hooks }, s, c) =
+ fun registerCollation (db as { ring=_, hooks, auth=_ }, s, c) =
hooks := Prim.createCollation (getDB db, s, c) :: !hooks
structure SQLite =
@@ -147,13 +152,22 @@
val totalChanges = Prim.totalChanges o getDB
val transactionActive = not o Prim.getAutocommit o getDB
- fun preparedQueries { ring, hooks=_ } =
+ fun preparedQueries { ring, hooks=_, auth=_ } =
Ring.fold (fn (_, x) => x + 1) ~1 ring
- fun registeredFunctions { ring=_, hooks } =
+ fun registeredFunctions { ring=_, hooks, auth=_ } =
List.length (!hooks)
datatype access = datatype Prim.access
datatype request = datatype Prim.request
- fun setAuthorizer (db, f) = Prim.setAuthorizer (getDB db, f)
+
+ fun setAuthorizer (dbh as { ring=_, hooks=_, auth }, f) =
+ let
+ val db = getDB dbh
+ fun unset h = (Prim.unsetAuthorizer db; Prim.unhook h; auth := NONE)
+ fun set f = auth := SOME (Prim.setAuthorizer (db, f))
+ in
+ Option.app unset (!auth);
+ Option.app set f
+ end
end
end
More information about the MLton-commit
mailing list