From 71420f8bc34bbe2c76bd368613d4e024072e9817 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 00:29:12 +0000 Subject: [PATCH 01/16] Full regeneration --- src/domain.sig | 9 +++++++++ src/domain.sml | 21 +++++++++++++++++++++ src/main.sml | 34 +++++++++++++++++++++++++++++++--- src/plugins/apache.sml | 3 +++ src/plugins/bind.sml | 4 ++++ src/plugins/webalizer.sml | 6 ++++++ 6 files changed, 74 insertions(+), 3 deletions(-) diff --git a/src/domain.sig b/src/domain.sig index 1d708f5..a937624 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -27,6 +27,15 @@ signature DOMAIN = sig val ip : string Env.arg + val registerResetGlobal : (unit -> unit) -> unit + val registerResetLocal : (unit -> unit) -> unit + (* Register functions for clearing out all Domtool configuration at the global + * (AFS) and local levels, respectively. *) + + val resetGlobal : unit -> unit + val resetLocal : unit -> unit + (* Call all registered functions *) + val registerBefore : (string -> unit) -> unit val registerAfter : (string -> unit) -> unit (* Register handlers to run just before and after entering a domain diff --git a/src/domain.sml b/src/domain.sml index 0354944..9913dfc 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -276,6 +276,27 @@ fun registerAfter f = afters := (fn x => (old x; f x)) end +val globals = ref (fn () => ()) +val locals = ref (fn () => ()) + +fun registerResetGlobal f = + let + val old = !globals + in + globals := (fn x => (old x; f x)) + end + +fun registerResetLocal f = + let + val old = !locals + in + locals := (fn x => (old x; f x)) + end + +fun resetGlobal () = (!globals (); + ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.resultRoot ^ "/*"))) +fun resetLocal () = !locals () + val current = ref "" val currentPath = ref (fn (_ : string) => "") diff --git a/src/main.sml b/src/main.sml index 715b486..f22c430 100644 --- a/src/main.sml +++ b/src/main.sml @@ -371,10 +371,35 @@ fun requestRmdom dom = OpenSSL.close bio end -fun regenerate () = +fun regenerate context = let val b = basis () - val _ = Tycheck.disallowExterns () + val () = Tycheck.disallowExterns () + + val () = Domain.resetGlobal () + + fun contactNode (node, ip) = + if node = Config.defaultNode then + Domain.resetLocal () + else let + val bio = OpenSSL.connect (context, + ip + ^ ":" + ^ Int.toString Config.slavePort) + in + Msg.send (bio, MsgRegenerate); + case Msg.recv bio of + NONE => print "Slave closed connection unexpectedly\n" + | SOME m => + case m of + MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n") + | MsgError s => print ("Slave " ^ node + ^ " returned error: " ^ + s ^ "\n") + | _ => print ("Slave " ^ node + ^ " returned unexpected command\n"); + OpenSSL.close bio + end fun doUser user = let @@ -408,6 +433,7 @@ fun regenerate () = handle IO.Io _ => () | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") in + app contactNode Config.nodeIps; Env.pre (); app doUser (Acl.users ()); Env.post () @@ -584,7 +610,7 @@ fun service () = | MsgRegenerate => if Acl.query {user = user, class = "priv", value = "regen"} orelse Acl.query {user = user, class = "priv", value = "all"} then - ((regenerate (); + ((regenerate context; Msg.send (bio, MsgOk); print "Regenerated all configuration.\n") handle OpenSSL.OpenSSL s => @@ -661,6 +687,8 @@ fun slave () = MsgFile file => loop' (file :: files) | MsgDoFiles => (Slave.handleChanges files; Msg.send (bio, MsgOk)) + | MsgRegenerate => (Domain.resetLocal (); + Msg.send (bio, MsgOk)) | _ => (print "Dispatcher sent unexpected command\n"; Msg.send (bio, MsgError "Unexpected command")) in diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 83a8ce8..65ba7fb 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -739,4 +739,7 @@ val () = Env.action_one "readmeName" write name; write "\n")) +val () = Domain.registerResetLocal (fn () => + ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*"))) + end diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml index 217ef45..9c72152 100644 --- a/src/plugins/bind.sml +++ b/src/plugins/bind.sml @@ -266,4 +266,8 @@ val () = Slave.registerPostHandler fn cl => "Error reloading bind with " ^ cl) else ())) + +val () = Domain.registerResetLocal (fn () => + ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/zones/*"))) + end diff --git a/src/plugins/webalizer.sml b/src/plugins/webalizer.sml index c6043af..7ac523b 100644 --- a/src/plugins/webalizer.sml +++ b/src/plugins/webalizer.sml @@ -116,4 +116,10 @@ val () = Slave.registerFileHandler (fn fs => | _ => () end) +val () = Domain.registerResetLocal (fn () => + app (fn (node, _) => + ignore (OS.Process.system (Config.rm ^ " -rf " + ^ Config.Webalizer.configDir ^ "/" + ^ node ^ "/*"))) Config.nodeIps) + end -- 2.20.1 From 9bdfa6e37cafe6249c5740859b794dd98ca07d86 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 00:31:21 +0000 Subject: [PATCH 02/16] Change domtool-publish to leave files alone if they don't have the right extension --- scripts/domtool-publish | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scripts/domtool-publish b/scripts/domtool-publish index fad7e85..1e934da 100755 --- a/scripts/domtool-publish +++ b/scripts/domtool-publish @@ -2,18 +2,18 @@ case $1 in apache) - /usr/bin/rsync -r --delete /var/domtool/vhosts/ /etc/apache2/vhosts/ + /usr/bin/rsync --delete /var/domtool/vhosts/*.vhost /etc/apache2/vhosts/ /etc/init.d/apache2 reload ;; apache-down) /etc/init.d/apache2 stop ;; apache-undown) - /usr/bin/rsync -r --delete /var/domtool/vhosts/ /etc/apache2/vhosts/ + /usr/bin/rsync --delete /var/domtool/vhosts/*.vhost /etc/apache2/vhosts/ /etc/init.d/apache2 start ;; bind) - /usr/bin/rsync -r --delete /var/domtool/zones/ /etc/bind/zones/ + /usr/bin/rsync --delete /var/domtool/zones/*.zone /etc/bind/zones/ /bin/cp /var/domtool/named.conf.local /etc/bind/ /etc/init.d/bind9 reload ;; -- 2.20.1 From 71ba8736cf965c9766aeb53810179e789e863846 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 00:32:32 +0000 Subject: [PATCH 03/16] Forget that change to domtool-publish --- scripts/domtool-publish | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scripts/domtool-publish b/scripts/domtool-publish index 1e934da..fad7e85 100755 --- a/scripts/domtool-publish +++ b/scripts/domtool-publish @@ -2,18 +2,18 @@ case $1 in apache) - /usr/bin/rsync --delete /var/domtool/vhosts/*.vhost /etc/apache2/vhosts/ + /usr/bin/rsync -r --delete /var/domtool/vhosts/ /etc/apache2/vhosts/ /etc/init.d/apache2 reload ;; apache-down) /etc/init.d/apache2 stop ;; apache-undown) - /usr/bin/rsync --delete /var/domtool/vhosts/*.vhost /etc/apache2/vhosts/ + /usr/bin/rsync -r --delete /var/domtool/vhosts/ /etc/apache2/vhosts/ /etc/init.d/apache2 start ;; bind) - /usr/bin/rsync --delete /var/domtool/zones/*.zone /etc/bind/zones/ + /usr/bin/rsync -r --delete /var/domtool/zones/ /etc/bind/zones/ /bin/cp /var/domtool/named.conf.local /etc/bind/ /etc/init.d/bind9 reload ;; -- 2.20.1 From 93c2f623c645cc089118a699874981d113540141 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 00:56:20 +0000 Subject: [PATCH 04/16] Recursive rmdom --- src/domain.sml | 43 ++++++++++++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/src/domain.sml b/src/domain.sml index 9913dfc..9234c7c 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -97,6 +97,8 @@ fun yourDomainHost s = (Substring.slice (suf, 1, NONE))) end +val yourDomain = yourDomainHost + fun validUser s = size s > 0 andalso size s < 20 andalso CharVector.all Char.isAlphaNum s @@ -662,20 +664,35 @@ fun rmdom dom = file = node} val dname = OS.Path.concat (dname, domPath) - val dir = Posix.FileSys.opendir dname - - fun loop actions = - case Posix.FileSys.readdir dir of - NONE => actions - | SOME fname => loop ({action = Slave.Delete, - domain = dom, - dir = dname, - file = OS.Path.joinDirFile {dir = dname, - file = fname}} :: actions) - - val actions = loop [] + fun visitDom (dom, dname, actions) = + let + val dir = Posix.FileSys.opendir dname + + fun loop actions = + case Posix.FileSys.readdir dir of + NONE => actions + | SOME fname => + let + val fnameFull = OS.Path.joinDirFile {dir = dname, + file = fname} + in + if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then + loop (visitDom (fname ^ "." ^ dom, + fnameFull, + actions)) + else + loop ({action = Slave.Delete, + domain = dom, + dir = dname, + file = fname} :: actions) + end + in + loop actions + before Posix.FileSys.closedir dir + end + + val actions = visitDom (dom, dname, []) in - Posix.FileSys.closedir dir; handleSite (node, actions) end handle IO.Io _ => print ("Warning: IO error deleting domain " ^ dom ^ " on " ^ node ^ ".\n") -- 2.20.1 From 77a8fca278b561808959fa1aa7d9f02c5cfe7720 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 01:08:19 +0000 Subject: [PATCH 05/16] Fix file paths for recursive rmdom --- src/domain.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/domain.sml b/src/domain.sml index 9234c7c..ca2f993 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -684,7 +684,7 @@ fun rmdom dom = loop ({action = Slave.Delete, domain = dom, dir = dname, - file = fname} :: actions) + file = fnameFull} :: actions) end in loop actions -- 2.20.1 From e69e60ccf1aa77a40cd5b15c4361f378ce332a42 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 18:53:44 +0000 Subject: [PATCH 06/16] Rmuser --- src/acl.sig | 5 +++ src/acl.sml | 12 +++++++ src/domain.sig | 2 +- src/domain.sml | 80 +++++++++++++++++++++++++++------------------- src/main-admin.sml | 2 +- src/main.sig | 3 +- src/main.sml | 62 ++++++++++++++++++++++++++++++++--- src/msg.sml | 9 ++++-- src/msgTypes.sml | 9 ++++-- 9 files changed, 138 insertions(+), 46 deletions(-) diff --git a/src/acl.sig b/src/acl.sig index 10abcde..846b331 100644 --- a/src/acl.sig +++ b/src/acl.sig @@ -43,6 +43,11 @@ signature ACL = sig val revoke : acl -> unit (* Grant/ungrant the user the permission. *) + val revokeFromAll : {class : string, value : string} -> unit + + val rmuser : string -> unit + (* Remove all of a user's privileges. *) + val read : string -> unit val write : string -> unit (* Read/write saved ACL state from/to a file *) diff --git a/src/acl.sml b/src/acl.sml index be30fdf..135e555 100644 --- a/src/acl.sml +++ b/src/acl.sml @@ -64,6 +64,10 @@ fun class {user, class} = NONE => SS.empty | SOME values => values +fun rmuser user = + (acl := #1 (SM.remove (!acl, user))) + handle NotFound => () + fun grant {user, class, value} = let val classes = Option.getOpt (SM.find (!acl, user), SM.empty) @@ -89,6 +93,14 @@ fun revoke {user, class, value} = values)) end +fun revokeFromAll {class, value} = + acl := SM.map (fn classes => + case SM.find (classes, class) of + NONE => classes + | SOME values => + ((SM.insert (classes, class, SS.delete (values, value))) + handle NotFound => classes)) (!acl) + fun read fname = let val inf = TextIO.openIn fname diff --git a/src/domain.sig b/src/domain.sig index a937624..642c0f4 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -74,5 +74,5 @@ signature DOMAIN = sig val hasPriv : string -> bool - val rmdom : string -> unit + val rmdom : string list -> unit end diff --git a/src/domain.sml b/src/domain.sml index ca2f993..04ee532 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -654,56 +654,70 @@ val _ = Env.type_one "mail_node" orelse (hasPriv "mail" andalso List.exists (fn x => x = node) Config.mailNodes_admin)) -fun rmdom dom = +fun rmdom doms = let - val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom)) - fun doNode (node, _) = let val dname = OS.Path.joinDirFile {dir = Config.resultRoot, file = node} - val dname = OS.Path.concat (dname, domPath) - fun visitDom (dom, dname, actions) = + fun doDom (dom, actions) = let - val dir = Posix.FileSys.opendir dname - - fun loop actions = - case Posix.FileSys.readdir dir of - NONE => actions - | SOME fname => - let - val fnameFull = OS.Path.joinDirFile {dir = dname, - file = fname} - in - if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then - loop (visitDom (fname ^ "." ^ dom, - fnameFull, - actions)) - else - loop ({action = Slave.Delete, - domain = dom, - dir = dname, - file = fnameFull} :: actions) - end + val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom)) + val dname = OS.Path.concat (dname, domPath) + + fun visitDom (dom, dname, actions) = + let + val dir = Posix.FileSys.opendir dname + + fun loop actions = + case Posix.FileSys.readdir dir of + NONE => actions + | SOME fname => + let + val fnameFull = OS.Path.joinDirFile {dir = dname, + file = fname} + in + if Posix.FileSys.ST.isDir (Posix.FileSys.stat fnameFull) then + loop (visitDom (fname ^ "." ^ dom, + fnameFull, + actions)) + else + loop ({action = Slave.Delete, + domain = dom, + dir = dname, + file = fnameFull} :: actions) + end + in + loop actions + before Posix.FileSys.closedir dir + end + handle OS.SysErr _ => + (print ("Warning: System error deleteing domain " ^ dom ^ " on " ^ node ^ ".\n"); + actions) in - loop actions - before Posix.FileSys.closedir dir + visitDom (dom, dname, actions) end - val actions = visitDom (dom, dname, []) + val actions = foldl doDom [] doms in handleSite (node, actions) end - handle IO.Io _ => print ("Warning: IO error deleting domain " ^ dom ^ " on " ^ node ^ ".\n") + handle IO.Io _ => print ("Warning: IO error deleting domains on " ^ node ^ ".\n") fun cleanupNode (node, _) = let - val dname = OS.Path.joinDirFile {dir = Config.resultRoot, - file = node} - val dname = OS.Path.concat (dname, domPath) + fun doDom dom = + let + val domPath = String.concatWith "/" (rev (String.fields (fn ch => ch = #".") dom)) + val dname = OS.Path.joinDirFile {dir = Config.resultRoot, + file = node} + val dname = OS.Path.concat (dname, domPath) + in + ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname)) + end in - ignore (OS.Process.system (Config.rm ^ " -rf " ^ dname)) + app doDom doms end in app doNode Config.nodeIps; diff --git a/src/main-admin.sml b/src/main-admin.sml index 2931ae6..7305822 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -41,6 +41,6 @@ val _ = (print ("whohas " ^ class ^ " / " ^ value ^ ":"); app (fn user => print (" " ^ user)) users; print "\n")) - | ["rmdom", dom] => Main.requestRmdom dom + | "rmdom" :: doms => Main.requestRmdom doms | ["regen"] => Main.requestRegen () | _ => print "Invalid command-line arguments\n" diff --git a/src/main.sig b/src/main.sig index c086bd5..791b357 100644 --- a/src/main.sig +++ b/src/main.sig @@ -38,8 +38,9 @@ signature MAIN = sig val requestRevoke : Acl.acl -> unit val requestListPerms : string -> (string * string list) list option val requestWhoHas : {class : string, value : string} -> string list option - val requestRmdom : string -> unit + val requestRmdom : string list -> unit val requestRegen : unit -> unit + val requestRmuser : string -> unit val service : unit -> unit val slave : unit -> unit diff --git a/src/main.sml b/src/main.sml index f22c430..997713d 100644 --- a/src/main.sml +++ b/src/main.sml @@ -371,6 +371,21 @@ fun requestRmdom dom = OpenSSL.close bio end +fun requestRmuser user = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRmuser user); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Removal succeeded.\n" + | MsgError s => print ("Removal failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun regenerate context = let val b = basis () @@ -439,6 +454,18 @@ fun regenerate context = Env.post () end +fun rmuser user = + let + val doms = Acl.class {user = user, class = "domain"} + val doms = List.filter (fn dom => + case Acl.whoHas {class = "domain", value = dom} of + [_] => true + | _ => false) (StringSet.listItems doms) + in + Acl.rmuser user; + Domain.rmdom doms + end + fun service () = let val () = Acl.read Config.aclFile @@ -583,12 +610,15 @@ fun service () = handle OpenSSL.OpenSSL _ => (); loop ()) - | MsgRmdom dom => + | MsgRmdom doms => if Acl.query {user = user, class = "priv", value = "all"} - orelse Acl.query {user = user, class = "domain", value = dom} then - ((Domain.rmdom dom; + orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then + ((Domain.rmdom doms; + app (fn dom => + Acl.revokeFromAll {class = "domain", value = dom}) doms; + Acl.write Config.aclFile; Msg.send (bio, MsgOk); - print ("Removed domain " ^ dom ^ ".\n")) + print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n")) handle OpenSSL.OpenSSL s => (print "OpenSSL error\n"; Msg.send (bio, @@ -629,6 +659,30 @@ fun service () = ignore (OpenSSL.readChar bio); OpenSSL.close bio) handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgRmuser user => + if Acl.query {user = user, class = "priv", value = "all"} then + ((rmuser user; + Acl.write Config.aclFile; + Msg.send (bio, MsgOk); + print ("Removed user " ^ user ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during revocation: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to remove users"); + print "Unauthorized user asked to remove a user!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); loop ()) | _ => diff --git a/src/msg.sml b/src/msg.sml index bb6a2b1..251626a 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -93,9 +93,11 @@ fun send (bio, m) = sendList OpenSSL.writeString (bio, users)) | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12); sendList OpenSSL.writeString (bio, codes)) - | MsgRmdom dom => (OpenSSL.writeInt (bio, 13); - OpenSSL.writeString (bio, dom)) + | MsgRmdom doms => (OpenSSL.writeInt (bio, 13); + sendList OpenSSL.writeString (bio, doms)) | MsgRegenerate => OpenSSL.writeInt (bio, 14) + | MsgRmuser dom => (OpenSSL.writeInt (bio, 15); + OpenSSL.writeString (bio, dom)) fun checkIt v = case v of @@ -143,8 +145,9 @@ fun recv bio = (recvList OpenSSL.readString bio) | 12 => Option.map MsgMultiConfig (recvList OpenSSL.readString bio) - | 13 => Option.map MsgRmdom (OpenSSL.readString bio) + | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio) | 14 => SOME MsgRegenerate + | 15 => Option.map MsgRmuser (OpenSSL.readString bio) | _ => NONE) end diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 89ab255..44f4178 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -46,10 +46,13 @@ datatype msg = (* These are the users! *) | MsgMultiConfig of string list (* Multiple Domtool sources in dependency order *) - | MsgRmdom of string - (* Remove all configuration associated with a domain and revoke rights - * to that domain from all users. *) + | MsgRmdom of string list + (* Remove all configuration associated with some domains and revoke + * rights to those domains from all users. *) | MsgRegenerate (* Make a clean slate of it and reprocess all configuration from scratch. *) + | MsgRmuser of string + (* Remove all ACL entries for a user, and remove all domains to which + * that user and no one else has rights. *) end -- 2.20.1 From f208fe7eb343486d3a464e0813d1cdce19b1ac5f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 18:59:48 +0000 Subject: [PATCH 07/16] Add rmuser command --- src/domain.sml | 2 +- src/main-admin.sml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/domain.sml b/src/domain.sml index 04ee532..3d8290b 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -693,7 +693,7 @@ fun rmdom doms = before Posix.FileSys.closedir dir end handle OS.SysErr _ => - (print ("Warning: System error deleteing domain " ^ dom ^ " on " ^ node ^ ".\n"); + (print ("Warning: System error deleting domain " ^ dom ^ " on " ^ node ^ ".\n"); actions) in visitDom (dom, dname, actions) diff --git a/src/main-admin.sml b/src/main-admin.sml index 7305822..c36da01 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -43,4 +43,5 @@ val _ = print "\n")) | "rmdom" :: doms => Main.requestRmdom doms | ["regen"] => Main.requestRegen () + | ["rmuser", user] => Main.requestRmuser user | _ => print "Invalid command-line arguments\n" -- 2.20.1 From 05323cbc31cd291e9708b034e9a8ac7dfebcd046 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 19:05:39 +0000 Subject: [PATCH 08/16] Fix use of wrong username for Rmuser --- src/main.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main.sml b/src/main.sml index 997713d..91ae29e 100644 --- a/src/main.sml +++ b/src/main.sml @@ -661,12 +661,12 @@ fun service () = handle OpenSSL.OpenSSL _ => (); loop ()) - | MsgRmuser user => + | MsgRmuser user' => if Acl.query {user = user, class = "priv", value = "all"} then - ((rmuser user; + ((rmuser user'; Acl.write Config.aclFile; Msg.send (bio, MsgOk); - print ("Removed user " ^ user ^ ".\n")) + print ("Removed user " ^ user' ^ ".\n")) handle OpenSSL.OpenSSL s => (print "OpenSSL error\n"; Msg.send (bio, -- 2.20.1 From 385c3534feda76934476fd3a058574fc84e302da Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 19:58:52 +0000 Subject: [PATCH 09/16] User add/remove scripts --- Makefile | 4 ++++ scripts/domtool-addacl | 5 +++++ scripts/domtool-addcert | 29 +++++++++++++++++++++++++++++ scripts/domtool-adduser | 4 ++++ scripts/domtool-rmuser | 5 +++++ 5 files changed, 47 insertions(+) create mode 100755 scripts/domtool-addacl create mode 100755 scripts/domtool-addcert create mode 100755 scripts/domtool-adduser create mode 100755 scripts/domtool-rmuser diff --git a/Makefile b/Makefile index 4dd594b..70a347c 100644 --- a/Makefile +++ b/Makefile @@ -94,6 +94,10 @@ install: cp scripts/domtool-publish /usr/local/sbin/ cp scripts/domtool-reset-global /usr/local/sbin/ cp scripts/domtool-reset-local /usr/local/sbin/ + cp scripts/domtool-adduser /usr/local/bin/ + cp scripts/domtool-addcert /usr/local/bin/ + cp scripts/domtool-addacl /usr/local/bin/ + cp scripts/domtool-rmuser /usr/local/bin/ cp openssl/openssl_sml.so /usr/local/lib/ cp bin/domtool-server /usr/local/sbin/ cp bin/domtool-slave /usr/local/sbin/ diff --git a/scripts/domtool-addacl b/scripts/domtool-addacl new file mode 100755 index 0000000..6675de0 --- /dev/null +++ b/scripts/domtool-addacl @@ -0,0 +1,5 @@ +#!/bin/sh -e + +domtool-admin grant $1 user $1 +domtool-admin grant $1 group $1 +domtool-admin grant $1 path /afs/hcoop.net/usr/$1 diff --git a/scripts/domtool-addcert b/scripts/domtool-addcert new file mode 100755 index 0000000..535d825 --- /dev/null +++ b/scripts/domtool-addcert @@ -0,0 +1,29 @@ +#!/bin/sh -e + + KEYDIR=/afs/hcoop.net/common/etc/domtool/keys/$1 + KEYFILE=$KEYDIR/key.pem +CERTFILE=/afs/hcoop.net/common/etc/domtool/certs/$1.pem + NEWREQ=~/.newreq.pem + NEW=~/.new.pem + KEYIN=~/.keyin + +mkdir $KEYDIR || echo Already exists +openssl genrsa -out $KEYFILE +chown -R domtool.domtool $KEYDIR +fs sa $KEYDIR $1 read +echo "." >$KEYIN +echo "." >>$KEYIN +echo "." >>$KEYIN +echo "." >>$KEYIN +echo "." >>$KEYIN +echo "$1" >>$KEYIN +echo "$1@hcoop.net" >>$KEYIN +echo "" >>$KEYIN +echo "" >>$KEYIN +openssl req -new -key $KEYFILE -out $NEWREQ -days 365 <$KEYIN +rm $KEYIN +cat $NEWREQ $KEYFILE >$NEW +rm $NEWREQ +openssl ca -batch -config /etc/domtool/openssl.cnf -policy policy_anything -out $CERTFILE -infiles $NEW +rm $NEW +chown domtool.domtool $CERTFILE diff --git a/scripts/domtool-adduser b/scripts/domtool-adduser new file mode 100755 index 0000000..3133cff --- /dev/null +++ b/scripts/domtool-adduser @@ -0,0 +1,4 @@ +#!/bin/sh -e + +domtool-addcert $* +domtool-addacl $* diff --git a/scripts/domtool-rmuser b/scripts/domtool-rmuser new file mode 100755 index 0000000..a296a3a --- /dev/null +++ b/scripts/domtool-rmuser @@ -0,0 +1,5 @@ +#!/bin/sh -e + +rm -rf /afs/hcoop.net/common/etc/domtool/keys/$1 +rm /afs/hcoop.net/common/etc/domtool/certs/$1.pem +domtool-admin rmuser $1 -- 2.20.1 From 44a5ce2fefb401654d7578db21f7e4e88b60b851 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 20:38:27 +0000 Subject: [PATCH 10/16] domtool-doc --- Makefile | 11 ++++++++++- bin/.cvsignore | 1 + src/.cvsignore | 1 + src/main-doc.sml | 42 ++++++++++++++++++++++++++++++++++++++++++ src/main.sig | 1 + src/main.sml | 9 +++++---- 6 files changed, 60 insertions(+), 5 deletions(-) create mode 100644 src/main-doc.sml diff --git a/Makefile b/Makefile index 70a347c..7cf54fa 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,8 @@ 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 +mlton: bin/domtool-server bin/domtool-client bin/domtool-slave \ + bin/domtool-admin bin/domtool-doc smlnj: $(COMMON_DEPS) openssl/smlnj/FFI/libssl.h.cm src/domtool.cm @@ -56,6 +57,10 @@ src/domtool-admin.mlb: Makefile 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 + $(MAKE_MLB_BASE) >src/domtool-doc.mlb + echo "main-doc.sml" >>src/domtool-doc.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*" \ @@ -90,6 +95,9 @@ bin/domtool-slave: $(COMMON_MLTON_DEPS) src/domtool-slave.mlb bin/domtool-admin: $(COMMON_MLTON_DEPS) src/domtool-admin.mlb mlton -output bin/domtool-admin -link-opt -ldl 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 + install: cp scripts/domtool-publish /usr/local/sbin/ cp scripts/domtool-reset-global /usr/local/sbin/ @@ -103,6 +111,7 @@ install: cp bin/domtool-slave /usr/local/sbin/ cp bin/domtool-client /usr/local/bin/domtool cp bin/domtool-admin /usr/local/bin/ + cp bin/domtool-doc /usr/local/bin/ .PHONY: grab_lib diff --git a/bin/.cvsignore b/bin/.cvsignore index 27134a3..16e624b 100644 --- a/bin/.cvsignore +++ b/bin/.cvsignore @@ -2,3 +2,4 @@ domtool-server domtool-client domtool-slave domtool-admin +domtool-doc diff --git a/src/.cvsignore b/src/.cvsignore index 29f6762..5356e7a 100644 --- a/src/.cvsignore +++ b/src/.cvsignore @@ -6,3 +6,4 @@ domtool-server.mlb domtool-client.mlb domtool-slave.mlb domtool-admin.mlb +domtool-doc.mlb diff --git a/src/main-doc.sml b/src/main-doc.sml new file mode 100644 index 0000000..3df2ad3 --- /dev/null +++ b/src/main-doc.sml @@ -0,0 +1,42 @@ +(* 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 documentation generation *) + +fun processArgs (args, basis, outdir, files) = + case args of + [] => (basis, outdir, files) + | "-basis" :: rest => processArgs (rest, true, outdir, files) + | "-out" :: dir :: rest => processArgs (rest, basis, dir, files) + | file :: rest => processArgs (rest, basis, outdir, file :: files) + +val _ = + let + val (basis, outdir, files) = processArgs (CommandLine.arguments (), + false, + OS.FileSys.getDir (), + []) + + val files = if basis then + Main.listBasis () @ files + else + files + in + Tycheck.allowExterns (); + Autodoc.autodoc {outdir = outdir, infiles = files} + end diff --git a/src/main.sig b/src/main.sig index 791b357..f8d6b94 100644 --- a/src/main.sig +++ b/src/main.sig @@ -45,6 +45,7 @@ signature MAIN = sig val service : unit -> unit val slave : unit -> unit + val listBasis : unit -> string list val autodocBasis : string -> unit end diff --git a/src/main.sml b/src/main.sml index 91ae29e..7457545 100644 --- a/src/main.sml +++ b/src/main.sml @@ -766,7 +766,7 @@ fun slave () = OpenSSL.shutdown sock end -fun autodocBasis outdir = +fun listBasis () = let val dir = Posix.FileSys.opendir Config.libRoot @@ -781,10 +781,11 @@ fun autodocBasis outdir = :: files) else loop files - - val files = loop [] in - Autodoc.autodoc {outdir = outdir, infiles = files} + loop [] end +fun autodocBasis outdir = + Autodoc.autodoc {outdir = outdir, infiles = listBasis ()} + end -- 2.20.1 From 76bad1b276ea45c07489dfbf0ec45a17f42f5a85 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Dec 2006 22:11:37 +0000 Subject: [PATCH 11/16] More forgiving make install --- Makefile | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 7cf54fa..d4c8990 100644 --- a/Makefile +++ b/Makefile @@ -107,11 +107,11 @@ install: cp scripts/domtool-addacl /usr/local/bin/ cp scripts/domtool-rmuser /usr/local/bin/ cp openssl/openssl_sml.so /usr/local/lib/ - cp bin/domtool-server /usr/local/sbin/ - cp bin/domtool-slave /usr/local/sbin/ - cp bin/domtool-client /usr/local/bin/domtool - cp bin/domtool-admin /usr/local/bin/ - cp bin/domtool-doc /usr/local/bin/ + -cp bin/domtool-server /usr/local/sbin/ + -cp bin/domtool-slave /usr/local/sbin/ + -cp bin/domtool-client /usr/local/bin/domtool + -cp bin/domtool-admin /usr/local/bin/ + -cp bin/domtool-doc /usr/local/bin/ .PHONY: grab_lib -- 2.20.1 From 3c855c4bab81d7d4adb54724f0e08be61a55241e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 17 Dec 2006 21:25:40 +0000 Subject: [PATCH 12/16] Fix user domtool directory resolution --- src/main-client.sml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/main-client.sml b/src/main-client.sml index c70dfb8..e017fc0 100644 --- a/src/main-client.sml +++ b/src/main-client.sml @@ -21,9 +21,11 @@ fun domtoolRoot () = let val uid = Posix.ProcEnv.getuid () - val home = Posix.SysDB.Passwd.home (Posix.SysDB.getpwuid uid) + val uname = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + val dname = OS.Path.joinDirFile {dir = Config.homeBase, + file = uname} in - OS.Path.joinDirFile {dir = home, + OS.Path.joinDirFile {dir = dname, file = "domtool"} end -- 2.20.1 From 8c142ff5a8d781a44261c1ca2f15f0e13a9d2e88 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 17 Dec 2006 22:40:01 +0000 Subject: [PATCH 13/16] More easy_domain --- lib/alias.dtl | 2 +- lib/domain.dtl | 4 ++++ lib/easy_domain.dtl | 5 +++++ lib/exim.dtl | 2 +- 4 files changed, 11 insertions(+), 2 deletions(-) diff --git a/lib/alias.dtl b/lib/alias.dtl index 8fe2246..10f7dde 100644 --- a/lib/alias.dtl +++ b/lib/alias.dtl @@ -28,7 +28,7 @@ extern val addressesTarget : [email] -> aliasTarget; extern val dropTarget : aliasTarget; {{Silently delete all mail to the associated source.}} -extern val aliasPrim : aliasSource -> aliasTarget -> [Domain] {MailNodes: [node]}; +extern val aliasPrim : aliasSource -> aliasTarget -> [Domain] {MailNodes: [mail_node]}; {{Request redirection of all mail from the source to the target, specifying on which nodes this redirection should be applied.}} diff --git a/lib/domain.dtl b/lib/domain.dtl index 5d2d057..afd922d 100644 --- a/lib/domain.dtl +++ b/lib/domain.dtl @@ -77,3 +77,7 @@ extern val noDns : dnsKind; extern val domain : your_domain -> Domain => [Root] {DNS : dnsKind, TTL : int}; {{Configure a domain to which you have access rights.}} + +extern type mail_node; +{{A node offering SMTP services}} +extern val mail_node_to_node : mail_node -> node; \ No newline at end of file diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl index 3c3d4e0..92a635f 100644 --- a/lib/easy_domain.dtl +++ b/lib/easy_domain.dtl @@ -32,3 +32,8 @@ val dom = config end; + +val nameserver = \host -> dns (dnsNS host); +val dnsIP = \from -> \to -> dns (dnsA from to); +val dnsMail = \num -> \host -> dns (dnsMX num host); +val dnsAlias = \from -> \to -> dns (dnsCNAME from to); diff --git a/lib/exim.dtl b/lib/exim.dtl index feb320e..3e9e749 100644 --- a/lib/exim.dtl +++ b/lib/exim.dtl @@ -1,4 +1,4 @@ {{Exim MTA configuration}} -extern val handleMail : [Domain] {MailNodes: [node]}; +extern val handleMail : [Domain] {MailNodes: [mail_node]}; {{The specified nodes should handle mail for this domain.}} -- 2.20.1 From d541c6185fb0f426dce0b16e85327b53635169e0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 21 Dec 2006 23:39:14 +0000 Subject: [PATCH 14/16] 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 From 90dd48df1de3ea116fe2f2c0ec0fe36c71e17e5c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 22 Dec 2006 00:07:54 +0000 Subject: [PATCH 15/16] 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 From ae1479386628436613a664b6601f6ca833dd6b2d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 22 Dec 2006 00:16:19 +0000 Subject: [PATCH 16/16] Add MySQL skeleton --- Makefile | 1 + configDefault/mysql.cfg | 6 ++++++ configDefault/mysql.cfs | 1 + configDefault/mysql.csg | 6 ++++++ src/plugins/domtool-mysql | 13 +++++++++++++ src/plugins/mysql.sig | 23 +++++++++++++++++++++++ src/plugins/mysql.sml | 38 ++++++++++++++++++++++++++++++++++++++ src/sources | 3 +++ 8 files changed, 91 insertions(+) create mode 100644 configDefault/mysql.cfg create mode 100644 configDefault/mysql.cfs create mode 100644 configDefault/mysql.csg create mode 100755 src/plugins/domtool-mysql create mode 100644 src/plugins/mysql.sig create mode 100644 src/plugins/mysql.sml diff --git a/Makefile b/Makefile index 1f780a4..33f7683 100644 --- a/Makefile +++ b/Makefile @@ -121,6 +121,7 @@ install: -cp bin/domtool-doc /usr/local/bin/ -cp bin/dbtool /usr/local/bin/ cp src/plugins/domtool-postgres /usr/local/sbin/ + cp src/plugins/domtool-mysql /usr/local/sbin/ .PHONY: grab_lib diff --git a/configDefault/mysql.cfg b/configDefault/mysql.cfg new file mode 100644 index 0000000..c199248 --- /dev/null +++ b/configDefault/mysql.cfg @@ -0,0 +1,6 @@ +structure MySQL :> MYSQL_CONFIG = struct + +val adduser = "/usr/bin/sudo /usr/local/sbin/domtool-mysql adduser " +val createdb = "/usr/bin/sudo /usr/local/sbin/domtool-mysql createdb " + +end diff --git a/configDefault/mysql.cfs b/configDefault/mysql.cfs new file mode 100644 index 0000000..987609c --- /dev/null +++ b/configDefault/mysql.cfs @@ -0,0 +1 @@ +structure MySQL : MYSQL_CONFIG diff --git a/configDefault/mysql.csg b/configDefault/mysql.csg new file mode 100644 index 0000000..7a05d02 --- /dev/null +++ b/configDefault/mysql.csg @@ -0,0 +1,6 @@ +signature MYSQL_CONFIG = sig + +val adduser : string +val createdb : string + +end diff --git a/src/plugins/domtool-mysql b/src/plugins/domtool-mysql new file mode 100755 index 0000000..9d02fc4 --- /dev/null +++ b/src/plugins/domtool-mysql @@ -0,0 +1,13 @@ +#!/bin/sh -e + +case $1 in + adduser) + echo "I would create MySQL user $2." + ;; + createdb) + echo "I would create MySQL table $2_$3 for user $2." + ;; + *) + echo "Usage: domtool-mysql [adduser | createdb
]" + ;; +esac diff --git a/src/plugins/mysql.sig b/src/plugins/mysql.sig new file mode 100644 index 0000000..9386c51 --- /dev/null +++ b/src/plugins/mysql.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. + *) + +(* MySQL user/table management *) + +signature MYSQL = sig + +end diff --git a/src/plugins/mysql.sml b/src/plugins/mysql.sml new file mode 100644 index 0000000..a273875 --- /dev/null +++ b/src/plugins/mysql.sml @@ -0,0 +1,38 @@ +(* 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. + *) + +(* MySQL user/table management *) + +structure MySQL :> MYSQL = struct + +fun adduser user = + if Slave.shell [Config.MySQL.adduser, user] then + NONE + else + SOME "Error executing CREATE USER script" + +fun createdb {user, dbname} = + if Slave.shell [Config.MySQL.createdb, user, " ", dbname] then + NONE + else + SOME "Error executing CREATE DATABASE script" + +val _ = Dbms.register ("mysql", {adduser = adduser, + createdb = createdb}) + +end diff --git a/src/sources b/src/sources index f5043b5..44126a3 100644 --- a/src/sources +++ b/src/sources @@ -80,6 +80,9 @@ plugins/hcoop.sml plugins/postgres.sig plugins/postgres.sml +plugins/mysql.sig +plugins/mysql.sml + order.sig order.sml -- 2.20.1