--- /dev/null
+(* 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.
+ *)
+
+(* Code for receiving and executing configuration files *)
+
+signature CLIENT = sig
+ datatype passwd_result =
+ Passwd of string
+ | Aborted
+ | Error
+
+ val getpass : unit -> passwd_result
+ (* Standard non-echoed console password input with confirmation *)
+end
--- /dev/null
+(* 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.
+ *)
+
+(* Code for receiving and executing configuration files *)
+
+structure Client :> CLIENT = struct
+
+datatype passwd_result =
+ Passwd of string
+ | Aborted
+ | Error
+
+fun getpass () =
+ let
+ val tty = Posix.FileSys.stdin
+ val termios = Posix.TTY.TC.getattr tty
+ val fields = Posix.TTY.fieldsOf termios
+
+ val termios' = Posix.TTY.termios {iflag = #iflag fields,
+ oflag = #oflag fields,
+ cflag = #cflag fields,
+ lflag = Posix.TTY.L.flags [Posix.TTY.L.clear (Posix.TTY.L.echo, #lflag fields),
+ Posix.TTY.L.echonl,
+ Posix.TTY.L.icanon],
+ cc = #cc fields,
+ ispeed = #ispeed fields,
+ ospeed = #ospeed fields}
+
+ fun reset () = Posix.TTY.TC.setattr (tty, Posix.TTY.TC.sanow, termios)
+ in
+ print " Password: ";
+ TextIO.flushOut TextIO.stdOut;
+ Posix.TTY.TC.setattr (tty, Posix.TTY.TC.sanow, termios');
+ case TextIO.inputLine TextIO.stdIn of
+ NONE => (reset ();
+ Aborted)
+ | SOME pass =>
+ (print "Confirm password: ";
+ TextIO.flushOut TextIO.stdOut;
+ case TextIO.inputLine TextIO.stdIn of
+ NONE => (reset ();
+ Aborted)
+ | SOME pass' =>
+ (reset ();
+ if pass = pass' then
+ Passwd (String.substring (pass, 0, size pass - 1))
+ else
+ (print "Passwords don't match!\n";
+ Error)))
+ end
+
+end
val validDbname : string -> bool
- type handler = {adduser : string -> string option,
+ type handler = {getpass : (unit -> Client.passwd_result) option,
+ adduser : {user : string, passwd : string option} -> string option,
createdb : {user : string, dbname : string} -> string option}
val register : string * handler -> unit
val validDbname = CharVector.all Char.isAlpha
-type handler = {adduser : string -> string option,
+type handler = {getpass : (unit -> Client.passwd_result) option,
+ adduser : {user : string, passwd : string option} -> string option,
createdb : {user : string, dbname : string} -> string option}
val dbmses : handler StringMap.map ref = ref StringMap.empty
| dbtype :: rest =>
case Dbms.lookup dbtype of
NONE => print ("Unknown database type " ^ dbtype ^ ".\n")
- | _ =>
+ | SOME {getpass, ...} =>
case rest of
- ["adduser"] => Main.requestDbUser dbtype
+ ["adduser"] =>
+ let
+ val pass = case getpass of
+ NONE => SOME NONE
+ | SOME f =>
+ case f () of
+ Client.Passwd pass => SOME (SOME pass)
+ | Client.Aborted => SOME NONE
+ | Client.Error => NONE
+ in
+ case pass of
+ NONE => ()
+ | SOME pass => Main.requestDbUser {dbtype = dbtype, passwd = pass}
+ end
| ["createdb", dbname] =>
if Dbms.validDbname dbname then
Main.requestDbTable {dbtype = dbtype, dbname = dbname}
val listBasis : unit -> string list
val autodocBasis : string -> unit
- val requestDbUser : string -> unit
+ val requestDbUser : {dbtype : string, passwd : string option} -> unit
val requestDbTable : {dbtype : string, dbname : string} -> unit
end
handle OpenSSL.OpenSSL _ => ();
loop ())
- | MsgCreateDbUser dbtype =>
+ | MsgCreateDbUser {dbtype, passwd} =>
(case Dbms.lookup dbtype of
NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
print ("Database user creation request with unknown datatype type " ^ dbtype);
handle OpenSSL.OpenSSL _ => ();
loop ())
| SOME handler =>
- case #adduser handler user of
+ case #adduser handler {user = user, passwd = passwd} of
NONE => ((Msg.send (bio, MsgOk);
print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n"))
handle OpenSSL.OpenSSL s =>
loop []
end
+fun sendOption f (bio, opt) =
+ case opt of
+ NONE => OpenSSL.writeInt (bio, 0)
+ | SOME x => (OpenSSL.writeInt (bio, 1);
+ f (bio, x))
+
+fun recvOption f bio =
+ case OpenSSL.readInt bio of
+ SOME 0 => SOME NONE
+ | SOME 1 =>
+ (case f bio of
+ SOME x => SOME (SOME x)
+ | NONE => NONE)
+ | _ => NONE
+
fun send (bio, m) =
case m of
MsgOk => OpenSSL.writeInt (bio, 1)
| 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))
+ | MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
+ OpenSSL.writeString (bio, dbtype);
+ sendOption OpenSSL.writeString (bio, passwd))
| MsgCreateDbTable {dbtype, dbname} => (OpenSSL.writeInt (bio, 17);
OpenSSL.writeString (bio, dbtype);
OpenSSL.writeString (bio, dbname))
| 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)
+ | 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
+ (SOME dbtype, SOME passwd) =>
+ SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
+ | _ => NONE)
| 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
(SOME dbtype, SOME dbname) =>
SOME (MsgCreateDbTable {dbtype = dbtype, dbname = dbname})
| 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
+ | MsgCreateDbUser of {dbtype : string, passwd : string option}
(* Request creation of a user for the named DBMS type *)
| MsgCreateDbTable of {dbtype : string, dbname : string}
(* Request creation of a DBMS table *)
case $1 in
adduser)
- echo "I would create MySQL user $2."
+ echo "I would create MySQL user $2 with password $3."
;;
createdb)
echo "I would create MySQL table $2_$3 for user $2."
structure MySQL :> MYSQL = struct
-fun adduser user =
- if Slave.shell [Config.MySQL.adduser, user] then
- NONE
- else
- SOME "Error executing CREATE USER script"
+val validPasswd = CharVector.all (fn ch => Char.isAlphaNum ch
+ orelse ch = #"!"
+ orelse ch = #"."
+ orelse ch = #"-"
+ orelse ch = #"_")
+
+fun adduser {user, passwd} =
+ case passwd of
+ NONE => SOME "No password given"
+ | SOME passwd =>
+ if validPasswd passwd then
+ if Slave.shell [Config.MySQL.adduser, user, " ", passwd] then
+ NONE
+ else
+ SOME "Error executing CREATE USER script"
+ else
+ SOME "Password contains characters besides letters, digits, and !.-_"
fun createdb {user, dbname} =
if Slave.shell [Config.MySQL.createdb, user, " ", dbname] then
else
SOME "Error executing CREATE DATABASE script"
-val _ = Dbms.register ("mysql", {adduser = adduser,
+val _ = Dbms.register ("mysql", {getpass = SOME Client.getpass,
+ adduser = adduser,
createdb = createdb})
end
structure Postgres :> POSTGRES = struct
-fun adduser user =
+fun adduser {user, passwd} =
if Slave.shell [Config.Postgres.adduser, user] then
NONE
else
else
SOME "Error executing CREATE DATABASE script"
-val _ = Dbms.register ("postgres", {adduser = adduser,
+val _ = Dbms.register ("postgres", {getpass = NONE,
+ adduser = adduser,
createdb = createdb})
end
openssl.sig
openssl.sml
+client.sig
+client.sml
+
dbms.sig
dbms.sml