From d541c6185fb0f426dce0b16e85327b53635169e0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 21 Dec 2006 23:39:14 +0000 Subject: [PATCH] Start of DBMS support --- Makefile | 23 ++++++++++++------ bin/.cvsignore | 1 + configDefault/postgres.cfg | 5 ++++ configDefault/postgres.cfs | 1 + configDefault/postgres.csg | 5 ++++ src/.cvsignore | 1 + src/dbms.sig | 28 +++++++++++++++++++++ src/dbms.sml | 34 ++++++++++++++++++++++++++ src/main-admin.sml | 2 +- src/main-client.sml | 2 +- src/main-dbtool.sml | 30 +++++++++++++++++++++++ src/main.sig | 2 ++ src/main.sml | 47 +++++++++++++++++++++++++++++++++++- src/msg.sml | 3 +++ src/msgTypes.sml | 2 ++ src/plugins/domtool-postgres | 13 ++++++++++ src/plugins/postgres.sig | 23 ++++++++++++++++++ src/plugins/postgres.sml | 31 ++++++++++++++++++++++++ src/sources | 6 +++++ 19 files changed, 249 insertions(+), 10 deletions(-) create mode 100644 configDefault/postgres.cfg create mode 100644 configDefault/postgres.cfs create mode 100644 configDefault/postgres.csg create mode 100644 src/dbms.sig create mode 100644 src/dbms.sml create mode 100644 src/main-dbtool.sml create mode 100755 src/plugins/domtool-postgres create mode 100644 src/plugins/postgres.sig create mode 100644 src/plugins/postgres.sml diff --git a/Makefile b/Makefile index d4c8990..1f780a4 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ COMMON_DEPS := configDefault/config.sig configDefault/configDefault.sml \ .PHONY: all mlton smlnj install mlton: bin/domtool-server bin/domtool-client bin/domtool-slave \ - bin/domtool-admin bin/domtool-doc + bin/domtool-admin bin/domtool-doc bin/dbtool smlnj: $(COMMON_DEPS) openssl/smlnj/FFI/libssl.h.cm src/domtool.cm @@ -34,33 +34,37 @@ openssl/openssl_sml.so: openssl/openssl_sml.o -o openssl/openssl_sml.so \ openssl/openssl_sml.o -lssl -src/domtool.cm: Makefile src/prefix.cm src/sources +src/domtool.cm: src/prefix.cm src/sources cat src/prefix.cm src/sources >src/domtool.cm MAKE_MLB_BASE := cat src/prefix.mlb src/sources src/suffix.mlb \ | sed 's/^\(.*\).grm$$/\1.grm.sig\n\1.grm.sml/' \ | sed 's/^\(.*\).lex$$/\1.lex.sml/' -src/domtool-server.mlb: Makefile src/prefix.mlb src/sources src/suffix.mlb +src/domtool-server.mlb: src/prefix.mlb src/sources src/suffix.mlb $(MAKE_MLB_BASE) >src/domtool-server.mlb echo "main-server.sml" >>src/domtool-server.mlb -src/domtool-client.mlb: Makefile src/prefix.mlb src/sources src/suffix.mlb +src/domtool-client.mlb: src/prefix.mlb src/sources src/suffix.mlb $(MAKE_MLB_BASE) >src/domtool-client.mlb echo "main-client.sml" >>src/domtool-client.mlb -src/domtool-slave.mlb: Makefile src/prefix.mlb src/sources src/suffix.mlb +src/domtool-slave.mlb: src/prefix.mlb src/sources src/suffix.mlb $(MAKE_MLB_BASE) >src/domtool-slave.mlb echo "main-slave.sml" >>src/domtool-slave.mlb -src/domtool-admin.mlb: Makefile src/prefix.mlb src/sources src/suffix.mlb +src/domtool-admin.mlb: src/prefix.mlb src/sources src/suffix.mlb $(MAKE_MLB_BASE) >src/domtool-admin.mlb echo "main-admin.sml" >>src/domtool-admin.mlb -src/domtool-doc.mlb: Makefile src/prefix.mlb src/sources src/suffix.mlb +src/domtool-doc.mlb: src/prefix.mlb src/sources src/suffix.mlb $(MAKE_MLB_BASE) >src/domtool-doc.mlb echo "main-doc.sml" >>src/domtool-doc.mlb +src/dbtool.mlb: src/prefix.mlb src/sources src/suffix.mlb + $(MAKE_MLB_BASE) >src/dbtool.mlb + echo "main-dbtool.sml" >>src/dbtool.mlb + openssl/smlnj/FFI/libssl.h.cm: openssl/openssl_sml.h cd openssl/smlnj ; ml-nlffigen -d FFI -lh LibsslH.libh -include ../libssl-h.sml \ -cm libssl.h.cm -D__builtin_va_list="void*" \ @@ -98,6 +102,9 @@ bin/domtool-admin: $(COMMON_MLTON_DEPS) src/domtool-admin.mlb bin/domtool-doc: $(COMMON_MLTON_DEPS) src/domtool-doc.mlb mlton -output bin/domtool-doc -link-opt -ldl src/domtool-doc.mlb +bin/dbtool: $(COMMON_MLTON_DEPS) src/dbtool.mlb + mlton -output bin/dbtool -link-opt -ldl src/dbtool.mlb + install: cp scripts/domtool-publish /usr/local/sbin/ cp scripts/domtool-reset-global /usr/local/sbin/ @@ -112,6 +119,8 @@ install: -cp bin/domtool-client /usr/local/bin/domtool -cp bin/domtool-admin /usr/local/bin/ -cp bin/domtool-doc /usr/local/bin/ + -cp bin/dbtool /usr/local/bin/ + cp src/plugins/domtool-postgres /usr/local/sbin/ .PHONY: grab_lib diff --git a/bin/.cvsignore b/bin/.cvsignore index 16e624b..dc4068c 100644 --- a/bin/.cvsignore +++ b/bin/.cvsignore @@ -3,3 +3,4 @@ domtool-client domtool-slave domtool-admin domtool-doc +dbtool diff --git a/configDefault/postgres.cfg b/configDefault/postgres.cfg new file mode 100644 index 0000000..dd00d3d --- /dev/null +++ b/configDefault/postgres.cfg @@ -0,0 +1,5 @@ +structure Postgres :> POSTGRES_CONFIG = struct + +val adduser = "/usr/bin/sudo /usr/local/sbin/domtool-postgres adduser " + +end diff --git a/configDefault/postgres.cfs b/configDefault/postgres.cfs new file mode 100644 index 0000000..d98e0c8 --- /dev/null +++ b/configDefault/postgres.cfs @@ -0,0 +1 @@ +structure Postgres : POSTGRES_CONFIG diff --git a/configDefault/postgres.csg b/configDefault/postgres.csg new file mode 100644 index 0000000..b4e6c09 --- /dev/null +++ b/configDefault/postgres.csg @@ -0,0 +1,5 @@ +signature POSTGRES_CONFIG = sig + +val adduser : string + +end diff --git a/src/.cvsignore b/src/.cvsignore index 5356e7a..18ad0fc 100644 --- a/src/.cvsignore +++ b/src/.cvsignore @@ -7,3 +7,4 @@ domtool-client.mlb domtool-slave.mlb domtool-admin.mlb domtool-doc.mlb +dbtool.mlb diff --git a/src/dbms.sig b/src/dbms.sig new file mode 100644 index 0000000..10bc467 --- /dev/null +++ b/src/dbms.sig @@ -0,0 +1,28 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* DBMS management code *) + +signature DBMS = sig + + type handler = {adduser : string -> string option} + + val register : string * handler -> unit + val lookup : string -> handler option + +end diff --git a/src/dbms.sml b/src/dbms.sml new file mode 100644 index 0000000..6f7bb9d --- /dev/null +++ b/src/dbms.sml @@ -0,0 +1,34 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* DBMS management code *) + +structure Dbms :> DBMS = struct + +open DataStructures + +type handler = {adduser : string -> string option} + +val dbmses : handler StringMap.map ref = ref StringMap.empty + +fun register (name, handler) = + dbmses := StringMap.insert (!dbmses, name, handler) + +fun lookup name = StringMap.find (!dbmses, name) + +end diff --git a/src/main-admin.sml b/src/main-admin.sml index c36da01..e3dc67b 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -16,7 +16,7 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) -(* Driver for server *) +(* Driver for admin requests *) fun requestPerms user = case Main.requestListPerms user of diff --git a/src/main-client.sml b/src/main-client.sml index e017fc0..57500c5 100644 --- a/src/main-client.sml +++ b/src/main-client.sml @@ -16,7 +16,7 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) -(* Driver for server *) +(* Driver for configuration requests *) fun domtoolRoot () = let diff --git a/src/main-dbtool.sml b/src/main-dbtool.sml new file mode 100644 index 0000000..98e6e03 --- /dev/null +++ b/src/main-dbtool.sml @@ -0,0 +1,30 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Driver for dbtool *) + +val _ = + case CommandLine.arguments () of + [] => print "Invalid command-line arguments\n" + | dbtype :: rest => + case Dbms.lookup dbtype of + NONE => print ("Unknown database type " ^ dbtype ^ ".\n") + | _ => + case rest of + ["adduser"] => Main.requestDbUser dbtype + | _ => print "Invalid command-line arguments\n" diff --git a/src/main.sig b/src/main.sig index f8d6b94..d6c64c5 100644 --- a/src/main.sig +++ b/src/main.sig @@ -48,4 +48,6 @@ signature MAIN = sig val listBasis : unit -> string list val autodocBasis : string -> unit + val requestDbUser : string -> unit + end diff --git a/src/main.sml b/src/main.sml index 7457545..f2a45c7 100644 --- a/src/main.sml +++ b/src/main.sml @@ -386,6 +386,21 @@ fun requestRmuser user = OpenSSL.close bio end +fun requestDbUser dbtype = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgCreateDbUser dbtype); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Your user 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 () @@ -683,7 +698,37 @@ fun service () = ignore (OpenSSL.readChar bio); OpenSSL.close bio) handle OpenSSL.OpenSSL _ => (); - loop ()) + loop ()) + + | MsgCreateDbUser dbtype => + (case Dbms.lookup dbtype of + NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype)); + print ("Database user creation request with unknown datatype type " ^ dbtype); + ignore (OpenSSL.readChar bio)) + handle OpenSSL.OpenSSL _ => (); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME handler => + case #adduser handler user of + NONE => ((Msg.send (bio, MsgOk); + print ("Added " ^ dbtype ^ " user " ^ user ^ ".\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 adding user: " ^ msg)); + print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n"); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ())) | _ => (Msg.send (bio, MsgError "Unexpected command") diff --git a/src/msg.sml b/src/msg.sml index 251626a..2b6cd20 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -98,6 +98,8 @@ fun send (bio, m) = | MsgRegenerate => OpenSSL.writeInt (bio, 14) | MsgRmuser dom => (OpenSSL.writeInt (bio, 15); OpenSSL.writeString (bio, dom)) + | MsgCreateDbUser s => (OpenSSL.writeInt (bio, 16); + OpenSSL.writeString (bio, s)) fun checkIt v = case v of @@ -148,6 +150,7 @@ fun recv bio = | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio) | 14 => SOME MsgRegenerate | 15 => Option.map MsgRmuser (OpenSSL.readString bio) + | 16 => Option.map MsgCreateDbUser (OpenSSL.readString bio) | _ => NONE) end diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 44f4178..0c7e5fe 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -54,5 +54,7 @@ datatype msg = | MsgRmuser of string (* Remove all ACL entries for a user, and remove all domains to which * that user and no one else has rights. *) + | MsgCreateDbUser of string + (* Request creation of a user for the named DBMS type *) end diff --git a/src/plugins/domtool-postgres b/src/plugins/domtool-postgres new file mode 100755 index 0000000..276637f --- /dev/null +++ b/src/plugins/domtool-postgres @@ -0,0 +1,13 @@ +#!/bin/sh -e + +case $1 in + adduser) + echo "I would create PostgreSQL user $2." + ;; + createdb) + echo "I would create PostgreSQL table $2_$3 for user $2." + ;; + *) + echo "Usage: domtool-postgres [adduser | createdb ]" + ;; +esac diff --git a/src/plugins/postgres.sig b/src/plugins/postgres.sig new file mode 100644 index 0000000..1f42d66 --- /dev/null +++ b/src/plugins/postgres.sig @@ -0,0 +1,23 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* PostgreSQL user/table management *) + +signature POSTGRES = sig + +end diff --git a/src/plugins/postgres.sml b/src/plugins/postgres.sml new file mode 100644 index 0000000..a267e4f --- /dev/null +++ b/src/plugins/postgres.sml @@ -0,0 +1,31 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* PostgreSQL user/table management *) + +structure Postgres :> POSTGRES = struct + +fun adduser user = + if Slave.shell [Config.Postgres.adduser, user] then + NONE + else + SOME "Error executing CREATE USER script" + +val _ = Dbms.register ("postgres", {adduser = adduser}) + +end diff --git a/src/sources b/src/sources index 3b78866..f5043b5 100644 --- a/src/sources +++ b/src/sources @@ -46,6 +46,9 @@ defaults.sml openssl.sig openssl.sml +dbms.sig +dbms.sml + msgTypes.sml msg.sig msg.sml @@ -74,6 +77,9 @@ plugins/mailman.sml plugins/hcoop.sig plugins/hcoop.sml +plugins/postgres.sig +plugins/postgres.sml + order.sig order.sml -- 2.20.1