From 90dd48df1de3ea116fe2f2c0ec0fe36c71e17e5c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 22 Dec 2006 00:07:54 +0000 Subject: [PATCH] DBMS database creation --- configDefault/postgres.cfg | 1 + configDefault/postgres.csg | 1 + src/dbms.sig | 5 +++- src/dbms.sml | 5 +++- src/main-dbtool.sml | 5 ++++ src/main.sig | 1 + src/main.sml | 53 ++++++++++++++++++++++++++++++++++++++ src/msg.sml | 7 +++++ src/msgTypes.sml | 2 ++ src/plugins/postgres.sml | 9 ++++++- 10 files changed, 86 insertions(+), 3 deletions(-) diff --git a/configDefault/postgres.cfg b/configDefault/postgres.cfg index dd00d3d..3205fcd 100644 --- a/configDefault/postgres.cfg +++ b/configDefault/postgres.cfg @@ -1,5 +1,6 @@ structure Postgres :> POSTGRES_CONFIG = struct val adduser = "/usr/bin/sudo /usr/local/sbin/domtool-postgres adduser " +val createdb = "/usr/bin/sudo /usr/local/sbin/domtool-postgres createdb " end diff --git a/configDefault/postgres.csg b/configDefault/postgres.csg index b4e6c09..e09637a 100644 --- a/configDefault/postgres.csg +++ b/configDefault/postgres.csg @@ -1,5 +1,6 @@ signature POSTGRES_CONFIG = sig val adduser : string +val createdb : string end diff --git a/src/dbms.sig b/src/dbms.sig index 10bc467..b2a74c0 100644 --- a/src/dbms.sig +++ b/src/dbms.sig @@ -20,7 +20,10 @@ signature DBMS = sig - type handler = {adduser : string -> string option} + val validDbname : string -> bool + + type handler = {adduser : string -> string option, + createdb : {user : string, dbname : string} -> string option} val register : string * handler -> unit val lookup : string -> handler option diff --git a/src/dbms.sml b/src/dbms.sml index 6f7bb9d..caf504a 100644 --- a/src/dbms.sml +++ b/src/dbms.sml @@ -22,7 +22,10 @@ structure Dbms :> DBMS = struct open DataStructures -type handler = {adduser : string -> string option} +val validDbname = CharVector.all Char.isAlpha + +type handler = {adduser : string -> string option, + createdb : {user : string, dbname : string} -> string option} val dbmses : handler StringMap.map ref = ref StringMap.empty diff --git a/src/main-dbtool.sml b/src/main-dbtool.sml index 98e6e03..73a02a2 100644 --- a/src/main-dbtool.sml +++ b/src/main-dbtool.sml @@ -27,4 +27,9 @@ val _ = | _ => case rest of ["adduser"] => Main.requestDbUser dbtype + | ["createdb", dbname] => + if Dbms.validDbname dbname then + Main.requestDbTable {dbtype = dbtype, dbname = dbname} + else + print ("Invalid database name " ^ dbname ^ ".\n") | _ => print "Invalid command-line arguments\n" diff --git a/src/main.sig b/src/main.sig index d6c64c5..7e2746a 100644 --- a/src/main.sig +++ b/src/main.sig @@ -49,5 +49,6 @@ signature MAIN = sig val autodocBasis : string -> unit val requestDbUser : string -> unit + val requestDbTable : {dbtype : string, dbname : string} -> unit end diff --git a/src/main.sml b/src/main.sml index f2a45c7..5f2038d 100644 --- a/src/main.sml +++ b/src/main.sml @@ -401,6 +401,21 @@ fun requestDbUser dbtype = OpenSSL.close bio end +fun requestDbTable p = + let + val (user, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgCreateDbTable p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n") + | MsgError s => print ("Creation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun regenerate context = let val b = basis () @@ -730,6 +745,44 @@ fun service () = handle OpenSSL.OpenSSL _ => (); loop ())) + | MsgCreateDbTable {dbtype, dbname} => + if Dbms.validDbname dbname then + (case Dbms.lookup dbtype of + NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype)); + print ("Database creation request with unknown datatype type " ^ dbtype); + ignore (OpenSSL.readChar bio)) + handle OpenSSL.OpenSSL _ => (); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME handler => + case #createdb handler {user = user, dbname = dbname} of + NONE => ((Msg.send (bio, MsgOk); + print ("Created database " ^ user ^ "_" ^ dbname ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during creation: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME msg => ((Msg.send (bio, MsgError ("Error creating database: " ^ msg)); + print ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg ^ "\n"); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ())) + else + ((Msg.send (bio, MsgError ("Invalid database name " ^ dbname)); + print ("Invalid database name " ^ user ^ "_" ^ dbname ^ "\n"); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + | _ => (Msg.send (bio, MsgError "Unexpected command") handle OpenSSL.OpenSSL _ => (); diff --git a/src/msg.sml b/src/msg.sml index 2b6cd20..23e8ac2 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -100,6 +100,9 @@ fun send (bio, m) = OpenSSL.writeString (bio, dom)) | MsgCreateDbUser s => (OpenSSL.writeInt (bio, 16); OpenSSL.writeString (bio, s)) + | MsgCreateDbTable {dbtype, dbname} => (OpenSSL.writeInt (bio, 17); + OpenSSL.writeString (bio, dbtype); + OpenSSL.writeString (bio, dbname)) fun checkIt v = case v of @@ -151,6 +154,10 @@ fun recv bio = | 14 => SOME MsgRegenerate | 15 => Option.map MsgRmuser (OpenSSL.readString bio) | 16 => Option.map MsgCreateDbUser (OpenSSL.readString bio) + | 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of + (SOME dbtype, SOME dbname) => + SOME (MsgCreateDbTable {dbtype = dbtype, dbname = dbname}) + | _ => NONE) | _ => NONE) end diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 0c7e5fe..adf1bba 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -56,5 +56,7 @@ datatype msg = * that user and no one else has rights. *) | MsgCreateDbUser of string (* Request creation of a user for the named DBMS type *) + | MsgCreateDbTable of {dbtype : string, dbname : string} + (* Request creation of a DBMS table *) end diff --git a/src/plugins/postgres.sml b/src/plugins/postgres.sml index a267e4f..87ba252 100644 --- a/src/plugins/postgres.sml +++ b/src/plugins/postgres.sml @@ -26,6 +26,13 @@ fun adduser user = else SOME "Error executing CREATE USER script" -val _ = Dbms.register ("postgres", {adduser = adduser}) +fun createdb {user, dbname} = + if Slave.shell [Config.Postgres.createdb, user, " ", dbname] then + NONE + else + SOME "Error executing CREATE DATABASE script" + +val _ = Dbms.register ("postgres", {adduser = adduser, + createdb = createdb}) end -- 2.20.1