[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