From d351d679283a797c98f5f65d18aa757c18e56305 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 21 Feb 2007 04:22:56 +0000 Subject: [PATCH] Cron and FTP queries --- src/compat_mlton.sml | 6 +++++ src/main-admin.sml | 2 ++ src/main.sig | 2 ++ src/main.sml | 62 ++++++++++++++++++++++++++++++++++++++++++++ src/msg.sml | 6 +++++ src/msgTypes.sml | 4 +++ src/plugins/cron.sig | 26 +++++++++++++++++++ src/plugins/cron.sml | 25 ++++++++++++++++++ src/plugins/ftp.sig | 26 +++++++++++++++++++ src/plugins/ftp.sml | 25 ++++++++++++++++++ src/prefix.mlb | 6 ++++- src/slave.sig | 4 +++ src/slave.sml | 14 ++++++++++ src/sources | 6 +++++ 14 files changed, 213 insertions(+), 1 deletion(-) create mode 100644 src/plugins/cron.sig create mode 100644 src/plugins/cron.sml create mode 100644 src/plugins/ftp.sig create mode 100644 src/plugins/ftp.sml diff --git a/src/compat_mlton.sml b/src/compat_mlton.sml index 5b52b14..06aa3a3 100644 --- a/src/compat_mlton.sml +++ b/src/compat_mlton.sml @@ -19,3 +19,9 @@ structure Compat : COMPAT = struct structure Char = MLRep.Char.Unsigned end + +val _ = let + open MLton.Signal +in + setHandler (Posix.Signal.pipe, Handler.ignore) +end diff --git a/src/main-admin.sml b/src/main-admin.sml index 7062972..5973689 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -49,4 +49,6 @@ val _ = | ["slave-shutdown"] => Main.requestSlaveShutdown () | ["slave-ping"] => OS.Process.exit (Main.requestSlavePing ()) | ["package", node, pkg] => OS.Process.exit (Main.requestApt {node = node, pkg = pkg}) + | ["cron", node, uname] => OS.Process.exit (Main.requestCron {node = node, uname = uname}) + | ["ftp", node, uname] => OS.Process.exit (Main.requestFtp {node = node, uname = uname}) | _ => print "Invalid command-line arguments\n" diff --git a/src/main.sig b/src/main.sig index 52f18b6..db8eea5 100644 --- a/src/main.sig +++ b/src/main.sig @@ -70,4 +70,6 @@ signature MAIN = sig val requestSmtpLog : string -> unit val requestApt : {node : string, pkg : string} -> OS.Process.status + val requestCron : {node : string, uname : string} -> OS.Process.status + val requestFtp : {node : string, uname : string} -> OS.Process.status end diff --git a/src/main.sml b/src/main.sml index 19fe40c..05bce83 100644 --- a/src/main.sml +++ b/src/main.sml @@ -633,6 +633,64 @@ fun requestApt {node, pkg} = before OpenSSL.close bio end +fun requestCron {node, uname} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QCron uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has cron permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have cron permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("Cron query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +fun requestFtp {node, uname} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QFtp uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has FTP permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have FTP permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("FTP query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let val b = basis () @@ -719,10 +777,14 @@ fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) fun answerQuery q = case q of QApt pkg => if Apt.installed pkg then MsgYes else MsgNo + | QCron user => if Cron.allowed user then MsgYes else MsgNo + | QFtp user => if Ftp.allowed user then MsgYes else MsgNo fun describeQuery q = case q of QApt pkg => "Requested installation status of package " ^ pkg + | QCron user => "Asked about cron permissions for user " ^ user + | QFtp user => "Asked about FTP permissions for user " ^ user fun service () = let diff --git a/src/msg.sml b/src/msg.sml index 5bf11f3..562c9d1 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -92,12 +92,18 @@ fun sendQuery (bio, q) = case q of QApt s => (OpenSSL.writeInt (bio, 0); OpenSSL.writeString (bio, s)) + | QCron s => (OpenSSL.writeInt (bio, 1); + OpenSSL.writeString (bio, s)) + | QFtp s => (OpenSSL.writeInt (bio, 2); + OpenSSL.writeString (bio, s)) fun recvQuery bio = case OpenSSL.readInt bio of SOME n => (case n of 0 => Option.map QApt (OpenSSL.readString bio) + | 1 => Option.map QCron (OpenSSL.readString bio) + | 2 => Option.map QFtp (OpenSSL.readString bio) | _ => NONE) | NONE => NONE diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 1ef2538..f51e780 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -23,6 +23,10 @@ structure MsgTypes = struct datatype query = QApt of string (* Is this apt package installed? *) + | QCron of string + (* Is this user allowed to use cron? *) + | QFtp of string + (* Is this user allowed to use FTP? *) datatype msg = MsgOk diff --git a/src/plugins/cron.sig b/src/plugins/cron.sig new file mode 100644 index 0000000..6b7b97a --- /dev/null +++ b/src/plugins/cron.sig @@ -0,0 +1,26 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006-2007, 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. + *) + +(* Cron permissions querying *) + +signature CRON = sig + + val allowed : string -> bool + (* Is the named user allowed to use cron here? *) + +end diff --git a/src/plugins/cron.sml b/src/plugins/cron.sml new file mode 100644 index 0000000..63cd57f --- /dev/null +++ b/src/plugins/cron.sml @@ -0,0 +1,25 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006-2007, 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. + *) + +(* Cron permissions querying *) + +structure Cron :> CRON = struct + +val allowed = Slave.lineInFile "/etc/cron.allow" + +end diff --git a/src/plugins/ftp.sig b/src/plugins/ftp.sig new file mode 100644 index 0000000..0a383f9 --- /dev/null +++ b/src/plugins/ftp.sig @@ -0,0 +1,26 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006-2007, 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. + *) + +(* FTP permissions querying *) + +signature FTP = sig + + val allowed : string -> bool + (* Is the named user allowed to use FTP here? *) + +end diff --git a/src/plugins/ftp.sml b/src/plugins/ftp.sml new file mode 100644 index 0000000..a9f8be6 --- /dev/null +++ b/src/plugins/ftp.sml @@ -0,0 +1,25 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006-2007, 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. + *) + +(* FTP permissions querying *) + +structure Ftp :> FTP = struct + +val allowed = Slave.lineInFile "/etc/ftpusers" + +end diff --git a/src/prefix.mlb b/src/prefix.mlb index 11c92f7..e95c596 100644 --- a/src/prefix.mlb +++ b/src/prefix.mlb @@ -9,5 +9,9 @@ $(SML_LIB)/mlnlffi-lib/internals/c-int.mlb ../openssl/mlton/FFI/libssl.h.mlb compat.sig -compat_mlton.sml +local + $(SML_LIB)/basis/mlton.mlb +in + compat_mlton.sml +end diff --git a/src/slave.sig b/src/slave.sig index b9abecd..a3d322f 100644 --- a/src/slave.sig +++ b/src/slave.sig @@ -60,4 +60,8 @@ signature SLAVE = sig val readList : string -> string list val writeList : string * string list -> unit (* Reading and writing lists of strings stored on separate lines in files *) + + val lineInFile : string -> string -> bool + (* Is there a line in the file (first arg) that matches that given? *) + end diff --git a/src/slave.sml b/src/slave.sml index 719b417..64613ed 100644 --- a/src/slave.sml +++ b/src/slave.sml @@ -181,4 +181,18 @@ fun writeList (fname, ls) = TextIO.closeOut outf end +fun lineInFile fname line = + let + val inf = TextIO.openIn fname + val line' = line ^ "\n" + + fun loop () = + case TextIO.inputLine inf of + NONE => false + | SOME line => line = line' orelse loop () + in + loop () + before TextIO.closeIn inf + end handle IO.Io _ => false + end diff --git a/src/sources b/src/sources index 3e132d6..ee48c10 100644 --- a/src/sources +++ b/src/sources @@ -89,6 +89,12 @@ plugins/mysql.sml plugins/apt.sig plugins/apt.sml +plugins/cron.sig +plugins/cron.sml + +plugins/ftp.sig +plugins/ftp.sml + mail/vmail.sig mail/vmail.sml -- 2.20.1