--- /dev/null
+CM
\ No newline at end of file
--- /dev/null
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+\f
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+\f
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+\f
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+\f
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+\f
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
--- /dev/null
+all: domtool webpasswd vmail reloadusers
+
+domtool:
+ mlton -output bin/domtool src/domtool.cm
+
+webpasswd:
+ mlton -output bin/webpasswd src/webpasswd/webpasswd.cm
+
+vmail:
+ mlton -output bin/vmail src/vmail/vmail.cm
+
+reloadusers:
+ mlton -output bin/reloadusers src/vmail/reloadusers.cm
\ No newline at end of file
--- /dev/null
+TOOLS FOR COOPERATIVE INTERNET HOSTING
+http://hcoop.sf.net/
+
+
+Introduction
+------------
+
+This package collects tools that have been found useful in running
+Internet servers cooperatively for the Internet Hosting Cooperative
+(http://hcoop.net/). The inclusion of all of them in this package
+isn't always particularly well motivated. However, everything here
+should be of potential interest to the general sysadminning public.
+
+The basic goal here is to provide Internet hosting services that meet
+the following criteria:
+ * A group of people share the resources of a server.
+ * People should be prevented from breaking other people's services.
+ * It should be easy to administer your own services.
+ * The base interface should be attractive to expert users, which
+includes making it relatively easy to manipulate with scripts.
+
+
+Domtool basics
+--------------
+
+The central organizing principle of the tools here is to represent all
+domains hosted on a machine as parts of a directory tree mirroring the
+structure of Internet domain names. Configuration files relevant to
+daemons that have per-domain/hostname configuration live in the
+directories for the domains whose settings they control. Standard UNIX
+filesystem permissions control who is allowed to change the settings
+for which domains.
+
+There are also additional controls related to which users, groups, and
+paths may be used in configuration files. Each directory in the domain
+tree may contain a .users file which lists UNIX usernames on separate
+lines. The union of the users specified in a domain's directory and
+all its parent directories in the domain tree specifies which users
+administrators of that domain are allowed to delegate for processes to
+run as. .groups files are treated analogously for UNIX groups. .paths
+files work in the same way for specifying filesystem paths that users
+are permitted to use in daemon configuration. Any recursive
+subdirectory of a path in .paths is also allowed.
+
+Obviously this system is useless if domain administrators are
+permitted to edit these files themselves. The tools that read config
+files will check that such files are owned by a set UNIX user, which
+will probably be a special user you create for domtool.
+
+For convenience, there is also a mechanism for defining
+variables. .vars files are treated in the same inheriting fashion, but
+they contain lines of variable names separated from their values by
+whitespace. Variables are currently intended to be used to give
+shorthand names for the IP addresses of particular machines that will
+often come up in configuration while avoiding the potential
+chicken-and-egg problem of looking up hostnames while configuring DNS.
+
+
+Software organization
+---------------------
+
+First things first: All of the software here is written in Standard
+ML. You can find compilers and educational material on it starting at
+http://www.standardml.org/. One of the domtool authors has also
+written an SML advocacy page that you can find at
+http://www.hprog.org/fhp/MlLanguage. We quite realize that SML is far
+from being popular with the general development community, but we hope
+you'll see why it's such a great language to use if you give it a try.
+
+The code in src/ handles the basic structure described above. Actual
+interaction with particular daemons is handled by
+modules. src/domtool.sig gives the interface that they may use to hook
+into the main tool. This transfer of control is based on configuration
+file names. Modules register particular configuration file names that
+they handle when such files are found in domain directories. There may
+also be one default handler registered, which is called for otherwise
+unmatched files that are valid Internet hostnames. Currently this is
+assumed to be a handler for Web virtual hosts, but it would be easy to
+do something else with these files.
+
+Tweakable configuration options are controlled throughout by SML
+source files. Everything is designed to be compiled with the MLton
+compiler (http://www.mlton.org/). MLton is a whole-program compiler
+and will integrate the settings in the various config files into the
+compiled code. If you have a current version of MLton installed, you
+should be able to run 'make' in this directory and build everything
+fine after you copy all config.sample.sml files to config.sml files
+and configure local settings.
+
+In the subdirectories of src/, you'll find various modules and
+additional command line programs. Each of these will typically have a
+config.sample.sml file that you should copy to config.sml and modify
+to set local options. Each should also contain a README file
+explaining the basics of the module or tool.
+
+
+Usage of the command-line tool
+------------------------------
+
+Running the program that builds in bin/domtool with no parameters will
+crawl over the domain tree reading configuration files. As it goes, it
+writes temporary versions of the new system configuration files in a
+location configured by the scratchDir variable in
+src/config.sml. After everything is read, a quick switch-over to the
+new files is performed, along with poking any daemons that need to
+reload configuration or restart. This change-over is done by running
+bin/domtool with the single argument 'publish'. It shouldn't be
+necessary to run this manually. Domtool itself will re-run itself with
+elevated permissions using sudo, or whatever other means you
+configure. (See below)
+
+The final way to use domtool is as follows:
+domtool mkdom domain.name user
+This creates the appropriate directory in the domain tree, setting it
+up to be administered by the specified UNIX user. It is not necessary
+to set up new domains this way. Just creating a directory in the right
+place will work fine. Mkdom just does some helpful things like
+automatically generating the access control files and chown'ing them
+to the right user.
+
+
+Handling permissions
+--------------------
+
+At hcoop, we make extensive use of sudo
+(http://www.courtesan.com/sudo/) to give our members access to
+modify system configuration files in safe ways. Here's the basic
+setup, which you may or may not want to emulate:
+
+We have a user 'domains.'
+
+We have the program that builds in bin/domtool in
+/usr/local/bin/domtool.real.
+
+We have a script in /usr/local/bin/domtool that runs:
+ sudo -u domains /usr/local/bin/domtool.real
+
+
+In /etc/sudoers, we have:
+
+A group of users allowed to run domtool:
+User_Alias DOMTOOL_USERS = user1,user2,user3
+
+Authorization for these users to run domtool as user domains:
+DOMTOOL_USERS ALL = (domains) NOPASSWD:
+/usr/local/bin/domtool.real
+
+Authorization for user domains to run domtool publish:
+domains ALL = (root) NOPASSWD:
+/usr/local/bin/domtool.real publish
--- /dev/null
+CM
+config.sml
\ No newline at end of file
--- /dev/null
+CM
+config.sml
\ No newline at end of file
--- /dev/null
+APACHE VIRTUAL HOST AND WEBALIZER CONFIGURATION
+
+
+This module handles configuration of Apache 1.3
+(http://httpd.apache.org/) virtual hosts, as well as automatically
+setting up Webalizer (http://www.mrunix.net/webalizer/) access
+statistics generation for each virtual host.
+
+Any file in a domain's directory whose name is a valid hostname (i.e.,
+www, myhost, etc.) is taken to be configuration for an Apache
+virtual host. These are separate web sites that Apache serves,
+differentiated based on the hostname contained in a request. The
+following configuration directives may appear on separate lines in
+such files:
+
+ * ServerAdmin email: Set the e-mail address of the vhost's admin to
+email.
+ * User user: Run CGI programs as UNIX user user. The default is
+nobody.
+ * Group group: Run CGI programs with UNIX group group. The
+default is nogroup. You are probably not in nogroup, so you
+probably want to include Group myuser if you also have User
+myuser.
+ * UserDir: Map requests to http://domain/~user/... to the
+corresponding files and directories in user's public_html
+directory, if he has one.
+ * DocumentRoot dir: Use dir as the base directory for site
+content.
+ * RewriteRule ...: These lines are passed verbatim to Apache's
+mod_rewrite (http://httpd.apache.org/docs/mod/mod_rewrite.html).
+ * Alias urldir realdir: Serve requests for things in directory
+urldir out of realdir.
+ * ScriptAlias urldir realdir: Like the above, but for scripts. It's
+like the same-named Apache directive.
+ * SSI: Enable server-side includes.
+ * ServerAlias hostname: Serve requests for full hostname hostname
+with this same vhost. There must exist an appropriate host.aliased
+file corresponding to hostname. For example, if hostname is
+my.web.site, the file /etc/domains/site/web/my.aliased must exist.
+ * WebalizerUsers userlist: Only allow users in space-separated
+userlist to view the Webalizer statistics for this vhost.
+ * AbuPrivate: Force visitors to this vhost to log in with their
+web accounts. The password file used for this is indicated by
+passwdFile in config.sml. Deny access if a correct username and
+password are not provided.
+ * CGI dir: Mark filesystem directory dir as containing executable
+CGI scripts/programs.
+ * Default: Where the configuration file is describing
+host.domain, this sets domain by itself as an alternate name for
+this vhost.
+ * ErrorDocument code url: This is the Apache ErrorDocument
+directive verbatim.
+ * HTML realdir: Serve every file in realdir as HTML.
+
+The src/webpasswd/ directory contains a handy tool for allowing users
+to set their own passwords and no one else's in an Apache password
+file. It's helpful to use along with the AbuPrivate and WebalizerUsers
+options.
+
+
+The module generates a file vhosts.conf containing only virtual host
+configuration. It is intended to be included by the standard
+httpd.conf after all server-wide configuration and a default virtual
+host block.
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+signature APACHE =
+sig
+
+end
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Apache vhost management module, with Webalizer support *)
+
+structure Apache :> APACHE =
+struct
+ open Config ApacheConfig Util
+
+ val vhosts = ref (NONE : TextIO.outstream option)
+
+ fun init () = vhosts := SOME (TextIO.openOut (scratchDir ^ "/vhosts.conf"))
+ fun finish () = (TextIO.closeOut (valOf (!vhosts));
+ vhosts := NONE)
+
+ fun handler {path, domain, parent, vars, paths, users, groups} =
+ let
+ val _ = Domtool.dprint ("Reading host " ^ path ^ " for " ^ domain ^ "....")
+
+ val vhosts = valOf (!vhosts)
+
+ val hf = TextIO.openIn path
+ val rewrite = ref false
+
+ val conf = TextIO.openOut (wblConfDir ^ "/" ^ domain ^ ".conf")
+ val _ = TextIO.output (conf, "LogFile\t" ^ logDir ^ domain ^ "-access.log\n" ^
+ "OutputDir\t" ^ wblDocDir ^ "/" ^ domain ^ "\n" ^
+ "HostName\t" ^ domain ^ "\n" ^
+ "HideSite\t" ^ domain ^ "\n" ^
+ "HideReferrer\t" ^ domain ^ "\n")
+
+ val dir = wblDocDir ^ "/" ^ domain
+ val _ =
+ if Posix.FileSys.access (dir, []) then
+ ()
+ else
+ Posix.FileSys.mkdir (dir, Posix.FileSys.S.flags [Posix.FileSys.S.ixoth, Posix.FileSys.S.irwxu,
+ Posix.FileSys.S.irgrp, Posix.FileSys.S.iwgrp])
+
+ val htac = TextIO.openOut (dir ^ "/.htaccess")
+ val user = ref defaultUser
+ val group = ref defaultGroup
+
+ fun loop (line, ()) =
+ (case String.tokens Char.isSpace line of
+ [] => ()
+ | ["User", user'] =>
+ if StringSet.member (users, user') then
+ user := user'
+ else
+ Domtool.error (path, "not authorized to run as " ^ user')
+ | ["Group", group'] =>
+ if StringSet.member (groups, group') then
+ group := group'
+ else
+ Domtool.error (path, "not authorized to run as group " ^ group')
+ | ["ServerAdmin", email] => TextIO.output (vhosts, "\tServerAdmin " ^ email ^ "\n")
+ | ["UserDir"] => TextIO.output (vhosts, "\tUserDir public_html\n\t<Directory /home/*/public_html/cgi-bin>\n\t\tAllowOverride None\n\t\tOptions ExecCGI\n\t\tAllow from all\n\t\tSetHandler cgi-script\n\t</Directory>\n\tScriptAliasMatch ^/~(.*)/cgi-bin/(.*) /home/$1/public_html/cgi-bin/$2\n")
+ | ["DocumentRoot", p] =>
+ if checkPath (paths, p) then
+ TextIO.output (vhosts, "\tDocumentRoot " ^ p ^ "\n")
+ else
+ print (path ^ ": not authorized to use " ^ p ^ "\n")
+ | "RewriteRule" :: args =>
+ (if not (!rewrite) then
+ (rewrite := true;
+ TextIO.output (vhosts, "\tRewriteEngine on\n"))
+ else
+ ();
+ TextIO.output (vhosts, foldl (fn (a, s) => s ^ " " ^ a) "\tRewriteRule" args ^ "\n"))
+ | ["Alias", from, to] =>
+ if checkPath (paths, to) then
+ TextIO.output (vhosts, "\tAlias " ^ from ^ " " ^ to ^ "\n")
+ else
+ Domtool.error (path, "not authorized to use " ^ to)
+ | "ErrorDocument" :: code :: rest =>
+ TextIO.output (vhosts, foldl (fn (a, s) => s ^ " " ^ a) ("\tErrorDocument " ^ code) rest ^ "\n")
+ | ["ScriptAlias", from, to] =>
+ if checkPath (paths, to) then
+ TextIO.output (vhosts, "\tScriptAlias " ^ from ^ " \"" ^ to ^ "\"\n")
+ else
+ Domtool.error (path, "not authorized to use " ^ to)
+ | ["SSI"] =>
+ TextIO.output (vhosts, "\t<Location />\n\t\tOptions +Includes +IncludesNOEXEC\n\t</Location>\n")
+ | ["ServerAlias", dom] =>
+ if validDomain dom then
+ let
+ val file = foldr (fn (c, s) => s ^ "/" ^ c) dataDir (String.fields (fn ch => ch = #".") dom) ^ ".aliased"
+ in
+ if Posix.FileSys.access (file, []) then
+ (TextIO.output (vhosts, "\tServerAlias " ^ dom ^ "\n");
+ TextIO.output (conf, "HideSite\t" ^ dom ^ "\n" ^
+ "HideReferrer\t" ^ dom ^ "\n"))
+ else
+ Domtool.error (path, "not authorized to ServerAlias " ^ dom)
+ end
+ else
+ Domtool.error (path, "bad host: " ^ dom)
+ | "WebalizerUsers" :: users =>
+ TextIO.output (htac, "AuthType Basic\n" ^
+ "AuthName \"Abulafia web account\"\n" ^
+ "AuthUserFile " ^ passwdFile ^ "\n" ^
+ foldl (fn (u, s) => s ^ " " ^ u) "Require user" users ^ "\n")
+ | ["AbuPrivate"] => TextIO.output (vhosts,
+ "\t<Location />\n" ^
+ "\t\tAuthName \"Abulafia web account\"\n" ^
+ "\t\tAuthType basic\n" ^
+ "\t\tAuthUserFile " ^ passwdFile ^ "\n" ^
+ "\t\tRequire valid-user\n" ^
+ "\t\tOrder Deny,Allow\n" ^
+ "\t\tDeny from all\n" ^
+ "\t\tAllow from 127.0.0.1\n" ^
+ "\t\tAllow from 63.246.10.45\n" ^
+ "\t\tSatisfy any\n" ^
+ "\t</Location>\n")
+ | ["Default"] => (TextIO.output (vhosts, "\tServerAlias " ^ parent ^ "\n");
+ TextIO.output (conf, "HideSite\t" ^ parent ^ "\n" ^
+ "HideReferrer\t" ^ parent ^ "\n"))
+ | ["CGI", p] =>
+ if checkPath (paths, p) then
+ TextIO.output (vhosts, "\t<Directory " ^ p ^ ">\n" ^
+ "\t\tOptions ExecCGI\n" ^
+ "\t\tSetHandler cgi-script\n" ^
+ "\t</Directory>\n")
+ else
+ Domtool.error (path, "not authorized to use " ^ p)
+ | ["HTML", p] =>
+ if checkPath (paths, p) then
+ TextIO.output (vhosts, "\t<Directory " ^ p ^ ">\n" ^
+ "\t\tForceType text/html\n" ^
+ "\t</Directory>\n")
+ else
+ Domtool.error (path, "not authorized to use " ^ p)
+ | cmd::_ => Domtool.error (path, "unknown option: " ^ cmd))
+ in
+ TextIO.output (vhosts, "<VirtualHost *>\n" ^
+ "\tServerName " ^ domain ^ "\n" ^
+ "\tErrorLog " ^ logDir ^ domain ^ "-error.log\n" ^
+ "\tCustomLog " ^ logDir ^ domain ^ "-access.log combined\n" ^
+ "\tIndexOptions FancyIndexing FoldersFirst\n");
+ ioLoop (fn () => Domtool.inputLine hf) loop ();
+ TextIO.output (vhosts, "\tUser ");
+ TextIO.output (vhosts, !user);
+ TextIO.output (vhosts, "\n\tGroup ");
+ TextIO.output (vhosts, !group);
+ TextIO.output (vhosts, "\n</VirtualHost>\n\n");
+ TextIO.closeIn hf;
+ TextIO.closeOut conf;
+ TextIO.closeOut htac
+ end handle Io => Domtool.error (path, "IO error")
+
+ fun publish () =
+ if OS.Process.isSuccess (OS.Process.system
+ (diff ^ " " ^ scratchDir ^ "/vhosts.conf " ^ dataFile)) then
+ OS.Process.success
+ else if not (OS.Process.isSuccess (OS.Process.system
+ (cp ^ " " ^ scratchDir ^ "/vhosts.conf " ^ dataFile))) then
+ (print "Error copying vhosts.conf\n";
+ OS.Process.failure)
+ else if OS.Process.isSuccess (OS.Process.system pubCommand) then
+ OS.Process.success
+ else
+ (print "Error publishing vhosts.conf\n";
+ OS.Process.failure)
+
+ fun mkdom _ = OS.Process.success
+
+ val _ = Domtool.setVhostHandler {init = init,
+ file = handler,
+ finish = finish,
+ publish = publish,
+ mkdom = mkdom}
+end
+
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Some options you might want to change *)
+
+structure ApacheConfig =
+struct
+ val logDir = "/var/log/apache/"
+ (* Where Apache writes log files *)
+
+ val wblConfDir = "/etc/webalizer"
+ (* Directory containing Webalizer .conf files *)
+
+ val wblDocDir = "/var/www/users.hcoop.net/html/webalizer"
+ (* Directory to use for outputting Webalizer results *)
+
+ val passwdFile = "/etc/apache/passwds"
+ (* Default system web password file *)
+
+ val defaultUser = "www-data"
+ (* Default UNIX user to allow a vhost to run as *)
+
+ val defaultGroup = "www-data"
+ (* Default UNIX group to allow a vhost to run as *)
+
+ val dataFile = "/etc/apache/vhosts.conf"
+ (* Location of real vhosts configuration file *)
+
+ val pubCommand = "/etc/init.d/apache reload"
+ (* Command to publish changes *)
+end
--- /dev/null
+Group is
+ config.sml
+ apache.sig
+ apache.sml
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Some options you might want to change *)
+
+structure Config =
+struct
+ (* Root of domain configuration tree *)
+ val dataDir = "/etc/domains"
+
+ (* Temporary location for new daemon config files before publishing *)
+ val scratchDir = "/home/domains"
+
+ (* Name of a directory to create/delete for locking purposes *)
+ val lockFile = "/home/domains/.lock"
+
+ (* UID of the user as whom domtool will run (used to check authenticity
+ * of .users, .groups, and .paths files) *)
+ val uid = 1031
+
+ (* Path to the config file for the default web vhost for this server.
+ * Configuration for this host will be ignored, leaving it up to admins to
+ * set it up manually.
+ *)
+ val defaultWebPath = "/etc/domains/net/hcoop/www"
+
+ (* When this is true, extra debug info may be printed. *)
+ val debug = false
+
+ (* Command to run dompub (probably as root) *)
+ val dompub = "sudo /usr/local/bin/domtool.real publish"
+
+ (* Paths to standard tools *)
+ val cp = "/bin/cp"
+ val diff = "/usr/bin/diff"
+ val cat = "/bin/cat"
+ val sudo = "/usr/bin/sudo"
+end
--- /dev/null
+CM
+config.sml
\ No newline at end of file
--- /dev/null
+DJBDNS DOMAIN NAME SERVER CONFIGURATION
+
+
+This module interfaces with djbdns (http://cr.yp.to/djbdns.html).
+
+A .dns file in a domain's directory controls its DNS settings. Such
+files consist of a sequence of lines of the following types:
+
+ * Primary host ip: Sets the primary DNS server for the domain to IP
+address ip, naming it host.domain
+ * Secondary host ip: Adds a secondary DNS server for the domain with
+IP address ip, naming it host.domain
+ * Mail host ip: Add a server to process e-mail for the domain with IP
+address ip, naming it host.domain. Mail servers will attempt to
+deliver mail to the servers you list following the order in which you
+list them, starting from the first.
+ * Default ip: Sets the IP address for domain to ip
+ * Host host ip: Sets the IP address for host.domain to ip
+ * Alias host ip: Sets the IP address for host.domain to ip; use this
+when this IP address has already been assigned a name in this domain
+with Default or Host
+ * Redir host1 host2: Sets host1.domain to have the same IP address as
+host2. This should almost never be used, as it requires every client
+resolution of this hostname to follow the chain of redirections,
+possibly across different servers. You should usually define a
+variable for a commonly used host IP address and use it with Host and
+Alias directives.
+
+
+All domains' mappings will be combined into a single file called
+data.shared in the domtool scratch directory. To publish, this file
+will be copied to the location specified in config.sml. Running make
+in the the djbns data root is a good thing to do in pubCommand to get
+changes propagated.
+
+This module tries to copy a default .dns file into new domain
+directories when mkdom is used. Be sure to set defaultFile to an
+appropriate filename if this is to work.
+
+When the module sees that a domain has an MX mapping, it can notify
+another module that mail for this domain should be accepted locally. A
+module that wants to receive this notification should call
+Djbdns.setLocalDomainHandler.
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Some options you might want to change *)
+
+structure DjbdnsConfig =
+struct
+ val dataFile = "/service/tinydns/root/data"
+ (* Place to publish djbdns format data *)
+
+ val pubCommand = "cd /service/tinydns/root ; /usr/bin/make"
+ (* Command to run to publish djbdns data *)
+
+ val defaultFile = "/etc/default.dns"
+ (* Default .dns file to install for new domains *)
+end
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+signature DJBDNS =
+sig
+ val setLocalDomainHandler : (string -> unit) -> unit
+ (* Function to call when a domain is discovered to make an MX delegation to
+ * this machine. *)
+end
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Djbdns DNS mapping config *)
+
+structure Djbdns :> DJBDNS =
+struct
+ open Config DjbdnsConfig Util
+
+ val ldHandler = ref (fn _ : string => ())
+ fun setLocalDomainHandler f = ldHandler := f
+
+ val dns = ref (NONE : TextIO.outstream option)
+
+ fun init () = dns := SOME (TextIO.openOut (scratchDir ^ "/data.shared"))
+ fun finish () = (TextIO.closeOut (valOf (!dns));
+ dns := NONE)
+
+ fun handler {path, domain, parent, vars, paths, users, groups} =
+ let
+ val _ = Domtool.dprint ("Reading dns " ^ path ^ " for " ^ parent ^ "....")
+
+ val dns = valOf (!dns)
+
+ val al = TextIO.openIn path
+
+ val hasEmail = ref false
+
+ fun loop (line, mxnum) =
+ let
+ fun err () = (Domtool.error (path, "Invalid entry: " ^ trimLast line);
+ mxnum)
+ in
+ case String.tokens Char.isSpace line of
+ [] => mxnum
+ | ["Default", addr] =>
+ (case resolveAddr (vars, addr) of
+ "" => err ()
+ | addr => (TextIO.output (dns, "=" ^ parent ^ ":" ^ addr ^ "\n");
+ mxnum))
+ | [ty, host, addr] =>
+ let
+ val pre =
+ (case ty of
+ "Primary" => "."
+ | "Secondary" => "&"
+ | "Host" => "="
+ | "Alias" => "+"
+ | "Mail" => "@"
+ | "Redir" => "C"
+ | _ => "")
+ in
+ if pre = "C" then
+ (case resolveDomain (vars, addr) of
+ "" => err ()
+ | host' =>
+ if validHost host then
+ (TextIO.output (dns, pre ^ host ^ "." ^ parent ^ ":" ^ addr ^ "\n");
+ mxnum)
+ else
+ err ())
+ else case (resolveAddr (vars, addr), pre) of
+ ("", _) => err ()
+ | (addr, ".") =>
+ if validHost host then
+ (TextIO.output (dns, pre ^ parent ^ ":" ^ addr ^ ":" ^ host ^ "." ^ parent ^ "\n");
+ mxnum)
+ else
+ err ()
+ | (addr, "&") =>
+ if validHost host then
+ (TextIO.output (dns, pre ^ parent ^ ":" ^ addr ^ ":" ^ host ^ "." ^ parent ^ "\n");
+ mxnum)
+ else
+ err ()
+ | (addr, "@") =>
+ (if not (!hasEmail) then
+ (hasEmail := true;
+ !ldHandler parent)
+ else
+ ();
+ if validHost host then
+ (TextIO.output (dns, pre ^ parent ^ ":" ^ addr ^ ":" ^ host ^ "." ^ parent ^ ":" ^ Int.toString mxnum ^ "\n");
+ mxnum+1)
+ else
+ err ())
+ | (addr, "=") =>
+ if validHost host then
+ (TextIO.output (dns, pre ^ host ^ "." ^ parent ^ ":" ^ addr ^ "\n");
+ mxnum)
+ else
+ err ()
+ | (addr, "+") =>
+ if validHost host then
+ (TextIO.output (dns, pre ^ host ^ "." ^ parent ^ ":" ^ addr ^ "\n");
+ mxnum)
+ else
+ err ()
+ | _ => err ()
+ end
+ | _ => err ()
+ end
+ in
+ ioLoop (fn () => Domtool.inputLine al) loop 0;
+ TextIO.closeIn al
+ end handle Io => Domtool.error (path, "IO error")
+
+ fun publish () =
+ if OS.Process.isSuccess (OS.Process.system
+ (diff ^ " " ^ scratchDir ^ "/data.shared " ^ dataFile)) then
+ OS.Process.success
+ else if not (OS.Process.isSuccess (OS.Process.system
+ (cp ^ " " ^ scratchDir ^ "/data.shared " ^ dataFile))) then
+ (print "Error copying data.shared\n";
+ OS.Process.failure)
+ else if OS.Process.isSuccess (OS.Process.system pubCommand) then
+ OS.Process.success
+ else
+ (print "Error publishing data.shared\n";
+ OS.Process.failure)
+
+ fun mkdom {path, ...} = OS.Process.system (cp ^ " " ^ defaultFile ^ " " ^ path ^ "/.dns")
+
+ val _ = Domtool.setHandler (".dns", {init = init,
+ file = handler,
+ finish = finish,
+ publish = publish,
+ mkdom = mkdom})
+end
--- /dev/null
+Group is
+ config.sml
+ djbdns.sig
+ djbdns.sml
\ No newline at end of file
--- /dev/null
+Group is
+ (*$/basis.cm*)
+
+ (*smlnj-lib/lib-base-sig.sml
+ smlnj-lib/lib-base.sml
+ smlnj-lib/ord-key-sig.sml
+ smlnj-lib/ord-map-sig.sml
+ smlnj-lib/binary-map-fn.sml
+ smlnj-lib/ord-set-sig.sml
+ smlnj-lib/binary-set-fn.sml*)
+ smlnj-lib/sources.cm
+
+ config.sml
+
+ map.sml
+
+ util.sig
+ util.sml
+
+ domtool.sig
+ domtool.sml
+
+(* Modules *)
+
+ (*apache/config.sml
+ apache/apache.sig
+ apache/apache.sml*)
+ apache/sources.cm
+
+ (*djbdns/config.sml
+ djbdns/djbdns.sig
+ djbdns/djbdns.sml*)
+ djbdns/sources.cm
+
+ exim/sources.cm
+
+
+ postconfig.sml
+
+ main.sml
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Main domtool structure *)
+
+signature DOMTOOL =
+sig
+ val dprint : string -> unit
+ (* If Config.debug, then it prints the argument followed by a newline. *)
+ val inputLine : TextIO.instream -> string option
+ (* Like TextIO.inputLine, but skips past lines commented out with #'s. *)
+
+ type map = string StringMap.map
+ type set = StringSet.set
+
+
+ val error : string * string -> unit
+ (* (error (path, msg)) signals an error about path with description msg. *)
+
+ (* Handlers for configuration files *)
+ type handlerData = {path : string, (* Path to the config file *)
+ domain : string, (* Domain in which it lives *)
+ parent : string, (* Parent of that domain *)
+ vars : map, (* Current variable values *)
+ paths : set, (* Authorized filesystem paths *)
+ users : set, (* Authorized UNIX users *)
+ groups : set} (* Authorized UNIX groups *)
+ type mkdomData = {path : string,
+ domain : string}
+ type handler = {init : unit -> unit,
+ file : handlerData -> unit,
+ finish : unit -> unit,
+ publish : unit -> OS.Process.status,
+ mkdom : mkdomData -> OS.Process.status}
+
+ val setVhostHandler : handler -> unit
+ (* Set the handler for virtual host configuration files *)
+ val setHandler : string * handler -> unit
+ (* Set the handler to be used for files with a specific name *)
+
+
+ val read : unit -> OS.Process.status
+ (* Command line domtool entry point *)
+ val publish : unit -> OS.Process.status
+ (* Propagate changes to real daemons *)
+ val mkDom : string * string -> OS.Process.status
+ (* (mkDom (dom, user)) creates a new domain record *)
+end
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Main domtool structure *)
+
+structure Domtool =
+struct
+ open Config Util
+
+ val uid = Posix.ProcEnv.wordToUid (SysWord.fromInt uid)
+
+ val dprint = if debug then (fn x => print (x ^ "\n")) else (fn _ => ())
+
+ fun openIn fname =
+ ((*dprint ("Open " ^ fname ^ "....");*)
+ TextIO.openIn fname)
+
+ fun opendir fname =
+ ((*dprint ("Open dir " ^ fname ^ "....");*)
+ Posix.FileSys.opendir fname)
+
+ fun inputLine fl =
+ let
+ val s = TextIO.inputLine fl
+ in
+ if size s = 0 orelse String.sub (s, 0) <> #"#" then
+ s
+ else
+ inputLine fl
+ end
+
+ fun hd' ([], x) = x
+ | hd' (h::_, _) = h
+
+ fun domPrep (a, b) =
+ (case b of
+ "" => a
+ | _ => a ^ "." ^ b)
+
+
+ type map = string StringMap.map
+ type set = StringSet.set
+
+ type handlerData = {path : string,
+ domain : string,
+ parent : string,
+ vars : map,
+ paths : set,
+ users : set,
+ groups : set}
+ type mkdomData = {path : string,
+ domain : string}
+ type handler = {init : unit -> unit,
+ file : handlerData -> unit,
+ finish : unit -> unit,
+ publish : unit -> OS.Process.status,
+ mkdom : mkdomData -> OS.Process.status}
+
+ val nullHandler = {init = fn () => (),
+ file = fn (_ : handlerData) => (),
+ finish = fn () => (),
+ publish = fn () => OS.Process.success,
+ mkdom = fn (_ : mkdomData) => OS.Process.success}
+
+ val vhostHandler = ref nullHandler
+ fun setVhostHandler f = vhostHandler := f
+
+ val handlers = ref (StringMap.empty : handler StringMap.map)
+ fun setHandler (fname, handler) = handlers := StringMap.insert (!handlers, fname, handler)
+
+ fun error (path, msg) = print (path ^ ": " ^ msg ^ "\n")
+
+ fun read () =
+ let
+ val vhostHandler = !vhostHandler
+
+ val _ = Posix.FileSys.mkdir (lockFile, Posix.FileSys.S.irwxu)
+
+ fun readDir (path, prefix, vars, paths, users, groups) =
+ let
+ val _ = dprint ("readDir: " ^ path)
+ val dir = opendir path
+
+ val vars =
+ if Posix.FileSys.access (path ^ "/.vars", []) then
+ let
+ val vf = openIn (path ^ "/.vars")
+
+ fun loop vars =
+ let
+ val line = inputLine vf
+ in
+ case line of
+ "" => vars
+ | _ =>
+ (case String.tokens Char.isSpace line of
+ [n, v] =>
+ if validHost n then
+ loop (StringMap.insert (vars, n, v))
+ else
+ (error (path ^ "/.vars", "Invalid variable declaration: " ^
+ String.substring (line, 0, size line - 1));
+ loop vars)
+ | _ => loop vars)
+ end
+ in
+ loop vars
+ before TextIO.closeIn vf
+ end
+ else
+ vars
+
+ val pp = path ^ "/.paths"
+ val paths =
+ if Posix.FileSys.access (pp, []) then
+ (if Posix.FileSys.ST.uid (Posix.FileSys.stat pp) = uid then
+ let
+ val vf = openIn pp
+
+ fun loop paths =
+ let
+ val line = inputLine vf
+ in
+ case line of
+ "" => paths
+ | _ =>
+ (case String.tokens Char.isSpace line of
+ [path] => loop (StringSet.add (paths, path))
+ | _ => loop paths)
+ end
+ in
+ loop paths
+ before TextIO.closeIn vf
+ end
+ else
+ (error (pp, "wrong owner to be used");
+ paths))
+ else
+ paths
+
+ val up = path ^ "/.users"
+ val users =
+ if Posix.FileSys.access (up, []) then
+ (if Posix.FileSys.ST.uid (Posix.FileSys.stat up) = uid then
+ let
+ val vf = openIn up
+
+ fun loop users =
+ let
+ val line = inputLine vf
+ in
+ case line of
+ "" => users
+ | _ =>
+ (case String.tokens Char.isSpace line of
+ [user] => loop (StringSet.add (users, user))
+ | _ => loop users)
+ end
+ in
+ loop users
+ before TextIO.closeIn vf
+ end
+ else
+ (error (up, ": wrong owner to be used.");
+ users))
+ else
+ users
+
+ val gp = path ^ "/.groups"
+ val groups =
+ if Posix.FileSys.access (gp, []) then
+ (if Posix.FileSys.ST.uid (Posix.FileSys.stat gp) = uid then
+ let
+ val vf = openIn gp
+
+ fun loop groups =
+ let
+ val line = inputLine vf
+ in
+ case line of
+ "" => groups
+ | _ =>
+ (case String.tokens Char.isSpace line of
+ [group] => loop (StringSet.add (groups, group))
+ | _ => loop groups)
+ end
+ in
+ loop groups
+ before TextIO.closeIn vf
+ end
+ else
+ (error (gp, "wrong owner to be used.");
+ groups))
+ else
+ groups
+
+ fun loop (name, ()) =
+ let
+ val path' = path ^ "/" ^ name
+ val prefix' = domPrep (name, prefix)
+ in
+ if not (Posix.FileSys.access (path', [])) then
+ ()
+ else if Posix.FileSys.ST.isDir (Posix.FileSys.stat path') then
+ readDir (path', prefix', vars, paths, users, groups)
+ else if isTmp name then
+ ()
+ else case StringMap.find (!handlers, name) of
+ NONE => if validHost name andalso path' <> defaultWebPath then
+ #file vhostHandler {path = path',
+ domain = prefix',
+ parent = prefix,
+ vars = vars,
+ paths = paths,
+ users = users,
+ groups = groups}
+ else
+ ()
+ | SOME {file, ...} => file {path = path',
+ domain = prefix',
+ parent = prefix,
+ vars = vars,
+ paths = paths,
+ users = users,
+ groups = groups}
+ end
+ in
+ ioOptLoop (fn () => Posix.FileSys.readdir dir) loop ();
+ Posix.FileSys.closedir dir
+ end handle Io => error (path, "IO error")
+ in
+ #init vhostHandler ();
+ StringMap.app (fn {init, ...} => init ()) (!handlers);
+ readDir (dataDir, "", StringMap.empty,
+ StringSet.empty, StringSet.empty, StringSet.empty);
+ StringMap.app (fn {finish, ...} => finish ()) (!handlers);
+ #finish vhostHandler ();
+ Posix.FileSys.rmdir lockFile;
+ print "Processing complete.\n";
+ OS.Process.system dompub
+ end handle Io => (print "IO error. Is domtool already running?\n";
+ OS.Process.failure)
+
+ fun combineStatus (a, b) =
+ if OS.Process.isSuccess a andalso OS.Process.isSuccess b then
+ OS.Process.success
+ else
+ OS.Process.failure
+
+ fun publish () =
+ StringMap.foldl (fn ({publish, ...}, status) =>
+ combineStatus (status, publish ()))
+ (#publish (!vhostHandler) ())
+ (!handlers)
+
+ fun mkdir dir =
+ let
+ fun mkd (tokens, acc) =
+ case tokens of
+ [] => true
+ | (dir::rest) =>
+ let
+ val dir = acc ^ "/" ^ dir
+ in
+ if not (Posix.FileSys.access (dir, []))
+ andalso OS.Process.system ("mkdir " ^ dir) = OS.Process.failure then
+ (print ("Can't created directory " ^ dir ^ "\n");
+ false)
+ else
+ mkd (rest, dir)
+ end
+ in
+ mkd (String.tokens (fn ch => ch = #"/") dir, dataDir)
+ end
+
+ fun mkdom (dom, user) =
+ if not (validDomain dom) then
+ (print "Invalid domain\n";
+ OS.Process.failure)
+ else if not (validUser user) then
+ (print "Invalid user\n";
+ OS.Process.failure)
+ else
+ let
+ val dir' = toDir dom
+ val dir = dataDir ^ dir'
+ in
+ if not (mkdir dir')
+ orelse OS.Process.system ("echo " ^ user ^ " >" ^ dir ^ "/.users") = OS.Process.failure
+ orelse OS.Process.system ("echo " ^ user ^ " >" ^ dir ^ "/.groups") = OS.Process.failure
+ orelse OS.Process.system ("echo /home/" ^ user ^ " >" ^ dir ^ "/.paths") = OS.Process.failure
+ orelse OS.Process.system ("chown -R " ^ user ^ "." ^ user ^ " " ^ dir) = OS.Process.failure
+ orelse OS.Process.system ("chmod -R g+w " ^ dir) = OS.Process.failure
+ orelse OS.Process.system ("chown domains.adm " ^ dir ^ "/.users " ^ dir ^ "/.groups " ^ dir ^ "/.paths") = OS.Process.failure then
+ (print "Setup failed\n";
+ OS.Process.failure)
+ else if not (OS.Process.isSuccess
+ (StringMap.foldl (fn ({mkdom, ...}, status) =>
+ combineStatus (status, mkdom {path = dir, domain = dom}))
+ (#mkdom (!vhostHandler) {path = dir, domain = dom})
+ (!handlers))) then
+ (print "Setup failed\n";
+ OS.Process.failure)
+ else
+ (print "Domain created\n";
+ OS.Process.success)
+ end
+end
--- /dev/null
+CM
+config.sml
\ No newline at end of file
--- /dev/null
+EXIM ALIAS AND LOCAL DOMAIN CONFIGURATION
+
+
+This module implements handling of e-mail aliases and configuring
+domains for which e-mail should be accepted locally for the exim MTA
+(http://www.exim.org).
+
+A .aliases file in a domain's directory controls its e-mail
+aliases. A target below may one of three things:
+
+ * a local username, to deliver mail to that user
+ * an e-mail address, to forward mail to it
+ * !, to delete mail to this address
+
+The file then consists of a sequence of lines of the following types.
+
+ * user target: Send all mail to user@domain to target
+ * * target: Send all mail to domain not matching any other rule
+to target. However, if mail is sent to an existing UNIX username on
+Abulafia, the message will go to that account
+ * ** target: Send all mail that does not match another rule to
+domain to target, even mail addressed to real UNIX usernames
+
+These policies are implemented by writing to two different alias files
+which are meant to be processed in different passes. The first one
+(probably /etc/aliases) should be check before exim checks an e-mail
+recipient against local useranmes or other special targets. After
+this, local usernames should be checked. Finally, the second alias
+file (such as /etc/aliases.default) should be checked, to implement
+"catch-all" addresses that handle all mail not matching other rules.
+
+
+The module also handles receiving notifications of which domains
+delegate mail handling to this host and incorporating this information
+into exim configuration files. A file local_domains is maintained in
+the domtool scratchDir, along with the last version of it in
+local_domains.last, to detect when changes have been made. The module
+will attempt to generate exim.conf by concatenatning local_domains and
+a file exim.base. The paths for these files are configurable in
+config.sml, as is the command used to tell exim to reload exim.conf
+afterwards.
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Some options you might want to change *)
+
+structure EximConfig =
+struct
+ val aliasesFile = "/etc/aliases"
+ (* File for first pass of e-mail aliases *)
+
+ val aliasesDefaultFile = "/etc/aliases.default"
+ (* File for second pass of e-mail aliases *)
+
+ val eximBase = "/etc/exim/exim.base"
+ (* Base exim configuration *)
+
+ val eximFile = "/etc/exim/exim.conf"
+ (* Exim config file *)
+
+ val pubCommand = "/etc/init.d/exim reload"
+ (* Command to publish data *)
+end
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+signature EXIM =
+sig
+ val localDomain : string -> unit
+ (* Registers that a domain's mail should be accepted locally *)
+end
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Exim e-mail alias and local domain configuration *)
+
+structure Exim :> EXIM =
+struct
+ open Config EximConfig Util
+
+ val aliases = ref (NONE : TextIO.outstream option)
+ val aliasesDefault = ref (NONE : TextIO.outstream option)
+ val local_domains = ref (NONE : TextIO.outstream option)
+
+ fun init () = (aliases := SOME (TextIO.openOut (scratchDir ^ "/aliases"));
+ aliasesDefault := SOME (TextIO.openOut (scratchDir ^ "/aliases.default"));
+ local_domains := SOME (TextIO.openOut (scratchDir ^ "/local_domains"));
+ TextIO.output (valOf (!local_domains), "local_domains = localhost"))
+ fun finish () = (TextIO.output (valOf (!local_domains), "\n\n");
+ TextIO.closeOut (valOf (!aliases));
+ aliases := NONE;
+ TextIO.closeOut (valOf (!aliasesDefault));
+ aliasesDefault := NONE;
+ TextIO.closeOut (valOf (!local_domains));
+ local_domains := NONE)
+
+ fun handler {path, domain, parent, vars, paths, users, groups} =
+ let
+ val _ = Domtool.dprint ("Reading aliases " ^ path ^ " for " ^ domain ^ "....")
+
+ val aliases = valOf (!aliases)
+ val aliasesDefault = valOf (!aliasesDefault)
+
+ val domain = "@" ^ parent
+ val al = TextIO.openIn path
+
+ fun loop (line, ()) =
+ let
+ fun err () = Domtool.error (path, "invalid entry: " ^ line)
+ in
+ case String.tokens Char.isSpace line of
+ [] => ()
+ | ["*", target] =>
+ if validUser target then
+ TextIO.output (aliasesDefault, "*" ^ domain ^ ":\t" ^ target ^ "@localhost\n")
+ else if validEmail target then
+ TextIO.output (aliasesDefault, "*" ^ domain ^ ":\t" ^ target ^ "\n")
+ else
+ err ()
+ | ["**", target] =>
+ if validUser target then
+ TextIO.output (aliases, "*" ^ domain ^ ":\t" ^ target ^ "@localhost\n")
+ else if validEmail target then
+ TextIO.output (aliases, "*" ^ domain ^ ":\t" ^ target ^ "\n")
+ else
+ err ()
+ | [user, target] =>
+ if validUser user then
+ (if target = "!" then
+ TextIO.output (aliases, user ^ domain ^ ":\t/dev/null\n")
+ else if validUser target then
+ TextIO.output (aliases, user ^ domain ^ ":\t" ^ target ^ "@localhost\n")
+ else if validEmail target then
+ TextIO.output (aliases, user ^ domain ^ ":\t" ^ target ^ "\n")
+ else
+ err ())
+ else
+ err ()
+ | _ => err ()
+ end
+ in
+ ioLoop (fn () => Domtool.inputLine al) loop ();
+ TextIO.closeIn al
+ end handle Io => Domtool.error (path, "IO error")
+
+ fun publish () =
+ if OS.Process.isSuccess (OS.Process.system
+ (diff ^ " " ^ scratchDir ^ "/aliases " ^ aliasesFile))
+ andalso OS.Process.isSuccess (OS.Process.system
+ (diff ^ " " ^ scratchDir ^ "/aliases.default " ^ aliasesDefaultFile))
+ andalso OS.Process.isSuccess (OS.Process.system
+ (diff ^ " " ^ scratchDir ^ "/local_domains " ^
+ scratchDir ^ "/local_domains.last"))
+ then
+ OS.Process.success
+ else if not (OS.Process.isSuccess (OS.Process.system
+ (cp ^ " " ^ scratchDir ^ "/aliases " ^ aliasesFile))) then
+ (print "Error copying aliases\n";
+ OS.Process.failure)
+ else if not (OS.Process.isSuccess (OS.Process.system
+ (cp ^ " " ^ scratchDir ^ "/aliases.default " ^ aliasesDefaultFile))) then
+ (print "Error copying aliases.default\n";
+ OS.Process.failure)
+ else if not (OS.Process.isSuccess (OS.Process.system
+ (cp ^ " " ^ scratchDir ^ "/local_domains " ^
+ scratchDir ^ "/local_domains.last"))) then
+ (print "Error copying local_domains\n";
+ OS.Process.failure)
+ else if not (OS.Process.isSuccess (OS.Process.system
+ (cat ^ " " ^ scratchDir ^ "/local_domains " ^ eximBase ^
+ " >" ^ eximFile))) then
+ (print "Error creating exim.conf\n";
+ OS.Process.failure)
+ else if OS.Process.isSuccess (OS.Process.system pubCommand) then
+ OS.Process.success
+ else
+ (print "Error publishing exim data\n";
+ OS.Process.failure)
+
+ fun mkdom _ = OS.Process.success
+
+ val _ = Domtool.setHandler (".aliases", {init = init,
+ file = handler,
+ finish = finish,
+ publish = publish,
+ mkdom = mkdom})
+
+ fun localDomain domain = TextIO.output (valOf (!local_domains), ":" ^ domain)
+end
+
+
--- /dev/null
+Group is
+ config.sml
+ exim.sig
+ exim.sml
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+val _ = OS.Process.exit (case CommandLine.arguments () of
+ [] => Domtool.read ()
+ | ["publish"] => Domtool.publish ()
+ | ["mkdom", dom, user] => Domtool.mkdom (dom, user)
+ | _ => (print "Invalid arguments\n";
+ OS.Process.failure))
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+structure StringKey =
+struct
+ type ord_key = string
+ val compare = String.compare
+end
+
+structure StringMap = BinaryMapFn (StringKey)
+structure StringSet = BinarySetFn (StringKey)
+
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Set some things up after all the modules are already loaded *)
+
+structure PostConfig =
+struct
+ val _ = Djbdns.setLocalDomainHandler Exim.localDomain
+end
\ No newline at end of file
--- /dev/null
+CM
\ No newline at end of file
--- /dev/null
+(* binary-map-fn.sml
+ *
+ * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
+ *
+ * This code was adapted from Stephen Adams' binary tree implementation
+ * of applicative integer sets.
+ *
+ * Copyright 1992 Stephen Adams.
+ *
+ * This software may be used freely provided that:
+ * 1. This copyright notice is attached to any copy, derived work,
+ * or work including all or part of this software.
+ * 2. Any derived work must contain a prominent notice stating that
+ * it has been altered from the original.
+ *
+ *
+ * Name(s): Stephen Adams.
+ * Department, Institution: Electronics & Computer Science,
+ * University of Southampton
+ * Address: Electronics & Computer Science
+ * University of Southampton
+ * Southampton SO9 5NH
+ * Great Britian
+ * E-mail: sra@ecs.soton.ac.uk
+ *
+ * Comments:
+ *
+ * 1. The implementation is based on Binary search trees of Bounded
+ * Balance, similar to Nievergelt & Reingold, SIAM J. Computing
+ * 2(1), March 1973. The main advantage of these trees is that
+ * they keep the size of the tree in the node, giving a constant
+ * time size operation.
+ *
+ * 2. The bounded balance criterion is simpler than N&R's alpha.
+ * Simply, one subtree must not have more than `weight' times as
+ * many elements as the opposite subtree. Rebalancing is
+ * guaranteed to reinstate the criterion for weight>2.23, but
+ * the occasional incorrect behaviour for weight=2 is not
+ * detrimental to performance.
+ *
+ *)
+
+functor BinaryMapFn (K : ORD_KEY) : ORD_MAP =
+ struct
+
+ structure Key = K
+
+ (*
+ ** val weight = 3
+ ** fun wt i = weight * i
+ *)
+ fun wt (i : int) = i + i + i
+
+ datatype 'a map
+ = E
+ | T of {
+ key : K.ord_key,
+ value : 'a,
+ cnt : int,
+ left : 'a map,
+ right : 'a map
+ }
+
+ val empty = E
+
+ fun isEmpty E = true
+ | isEmpty _ = false
+
+ fun numItems E = 0
+ | numItems (T{cnt,...}) = cnt
+
+ (* return the first item in the map (or NONE if it is empty) *)
+ fun first E = NONE
+ | first (T{value, left=E, ...}) = SOME value
+ | first (T{left, ...}) = first left
+
+ (* return the first item in the map and its key (or NONE if it is empty) *)
+ fun firsti E = NONE
+ | firsti (T{key, value, left=E, ...}) = SOME(key, value)
+ | firsti (T{left, ...}) = firsti left
+
+local
+ fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
+ | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r}
+ | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E}
+ | N(k,v,l as T n,r as T n') =
+ T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r}
+
+ fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) =
+ N(b,bv,N(a,av,x,y),z)
+ | single_L _ = raise Match
+ fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) =
+ N(a,av,x,N(b,bv,y,z))
+ | single_R _ = raise Match
+ fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) =
+ N(b,bv,N(a,av,w,x),N(c,cv,y,z))
+ | double_L _ = raise Match
+ fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) =
+ N(b,bv,N(a,av,w,x),N(c,cv,y,z))
+ | double_R _ = raise Match
+
+ fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
+ | T' (k,v,E,r as T{right=E,left=E,...}) =
+ T{key=k,value=v,cnt=2,left=E,right=r}
+ | T' (k,v,l as T{right=E,left=E,...},E) =
+ T{key=k,value=v,cnt=2,left=l,right=E}
+
+ | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p
+ | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p
+
+ (* these cases almost never happen with small weight*)
+ | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) =
+ if ln < rn then single_L p else double_L p
+ | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) =
+ if ln > rn then single_R p else double_R p
+
+ | T' (p as (_,_,E,T{left=E,...})) = single_L p
+ | T' (p as (_,_,T{right=E,...},E)) = single_R p
+
+ | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...},
+ r as T{cnt=rn,left=rl,right=rr,...})) =
+ if rn >= wt ln then (*right is too big*)
+ let val rln = numItems rl
+ val rrn = numItems rr
+ in
+ if rln < rrn then single_L p else double_L p
+ end
+
+ else if ln >= wt rn then (*left is too big*)
+ let val lln = numItems ll
+ val lrn = numItems lr
+ in
+ if lrn < lln then single_R p else double_R p
+ end
+
+ else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r}
+
+ local
+ fun min (T{left=E,key,value,...}) = (key,value)
+ | min (T{left,...}) = min left
+ | min _ = raise Match
+
+ fun delmin (T{left=E,right,...}) = right
+ | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right)
+ | delmin _ = raise Match
+ in
+ fun delete' (E,r) = r
+ | delete' (l,E) = l
+ | delete' (l,r) = let val (mink,minv) = min r in
+ T'(mink,minv,l,delmin r)
+ end
+ end
+in
+ fun mkDict () = E
+
+ fun singleton (x,v) = T{key=x,value=v,cnt=1,left=E,right=E}
+
+ fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E}
+ | insert (T(set as {key,left,right,value,...}),x,v) =
+ case K.compare (key,x) of
+ GREATER => T'(key,value,insert(left,x,v),right)
+ | LESS => T'(key,value,left,insert(right,x,v))
+ | _ => T{key=x,value=v,left=left,right=right,cnt= #cnt set}
+ fun insert' ((k, x), m) = insert(m, k, x)
+
+ fun inDomain (set, x) = let
+ fun mem E = false
+ | mem (T(n as {key,left,right,...})) = (case K.compare (x,key)
+ of GREATER => mem right
+ | EQUAL => true
+ | LESS => mem left
+ (* end case *))
+ in
+ mem set
+ end
+
+ fun find (set, x) = let
+ fun mem E = NONE
+ | mem (T(n as {key,left,right,...})) = (case K.compare (x,key)
+ of GREATER => mem right
+ | EQUAL => SOME(#value n)
+ | LESS => mem left
+ (* end case *))
+ in
+ mem set
+ end
+
+ fun remove (E,x) = raise LibBase.NotFound
+ | remove (set as T{key,left,right,value,...},x) = (
+ case K.compare (key,x)
+ of GREATER => let
+ val (left', v) = remove(left, x)
+ in
+ (T'(key, value, left', right), v)
+ end
+ | LESS => let
+ val (right', v) = remove (right, x)
+ in
+ (T'(key, value, left, right'), v)
+ end
+ | _ => (delete'(left,right),value)
+ (* end case *))
+
+ fun listItems d = let
+ fun d2l (E, l) = l
+ | d2l (T{key,value,left,right,...}, l) =
+ d2l(left, value::(d2l(right,l)))
+ in
+ d2l (d,[])
+ end
+
+ fun listItemsi d = let
+ fun d2l (E, l) = l
+ | d2l (T{key,value,left,right,...}, l) =
+ d2l(left, (key,value)::(d2l(right,l)))
+ in
+ d2l (d,[])
+ end
+
+ fun listKeys d = let
+ fun d2l (E, l) = l
+ | d2l (T{key,left,right,...}, l) = d2l(left, key::(d2l(right,l)))
+ in
+ d2l (d,[])
+ end
+
+ local
+ fun next ((t as T{right, ...})::rest) = (t, left(right, rest))
+ | next _ = (E, [])
+ and left (E, rest) = rest
+ | left (t as T{left=l, ...}, rest) = left(l, t::rest)
+ in
+ fun collate cmpRng (s1, s2) = let
+ fun cmp (t1, t2) = (case (next t1, next t2)
+ of ((E, _), (E, _)) => EQUAL
+ | ((E, _), _) => LESS
+ | (_, (E, _)) => GREATER
+ | ((T{key=x1, value=y1, ...}, r1), (T{key=x2, value=y2, ...}, r2)) => (
+ case Key.compare(x1, x2)
+ of EQUAL => (case cmpRng(y1, y2)
+ of EQUAL => cmp (r1, r2)
+ | order => order
+ (* end case *))
+ | order => order
+ (* end case *))
+ (* end case *))
+ in
+ cmp (left(s1, []), left(s2, []))
+ end
+ end (* local *)
+
+ fun appi f d = let
+ fun app' E = ()
+ | app' (T{key,value,left,right,...}) = (
+ app' left; f(key, value); app' right)
+ in
+ app' d
+ end
+ fun app f d = let
+ fun app' E = ()
+ | app' (T{value,left,right,...}) = (
+ app' left; f value; app' right)
+ in
+ app' d
+ end
+
+ fun mapi f d = let
+ fun map' E = E
+ | map' (T{key,value,left,right,cnt}) = let
+ val left' = map' left
+ val value' = f(key, value)
+ val right' = map' right
+ in
+ T{cnt=cnt, key=key, value=value', left = left', right = right'}
+ end
+ in
+ map' d
+ end
+ fun map f d = mapi (fn (_, x) => f x) d
+
+ fun foldli f init d = let
+ fun fold (E, v) = v
+ | fold (T{key,value,left,right,...}, v) =
+ fold (right, f(key, value, fold(left, v)))
+ in
+ fold (d, init)
+ end
+ fun foldl f init d = foldli (fn (_, v, accum) => f (v, accum)) init d
+
+ fun foldri f init d = let
+ fun fold (E,v) = v
+ | fold (T{key,value,left,right,...},v) =
+ fold (left, f(key, value, fold(right, v)))
+ in
+ fold (d, init)
+ end
+ fun foldr f init d = foldri (fn (_, v, accum) => f (v, accum)) init d
+
+(** To be implemented **
+ val filter : ('a -> bool) -> 'a map -> 'a map
+ val filteri : (Key.ord_key * 'a -> bool) -> 'a map -> 'a map
+**)
+
+ end (* local *)
+
+(* the following are generic implementations of the unionWith, intersectWith,
+ * and mergeWith operetions. These should be specialized for the internal
+ * representations at some point.
+ *)
+ fun unionWith f (m1, m2) = let
+ fun ins f (key, x, m) = (case find(m, key)
+ of NONE => insert(m, key, x)
+ | (SOME x') => insert(m, key, f(x, x'))
+ (* end case *))
+ in
+ if (numItems m1 > numItems m2)
+ then foldli (ins (fn (a, b) => f (b, a))) m1 m2
+ else foldli (ins f) m2 m1
+ end
+ fun unionWithi f (m1, m2) = let
+ fun ins f (key, x, m) = (case find(m, key)
+ of NONE => insert(m, key, x)
+ | (SOME x') => insert(m, key, f(key, x, x'))
+ (* end case *))
+ in
+ if (numItems m1 > numItems m2)
+ then foldli (ins (fn (k, a, b) => f (k, b, a))) m1 m2
+ else foldli (ins f) m2 m1
+ end
+
+ fun intersectWith f (m1, m2) = let
+ (* iterate over the elements of m1, checking for membership in m2 *)
+ fun intersect f (m1, m2) = let
+ fun ins (key, x, m) = (case find(m2, key)
+ of NONE => m
+ | (SOME x') => insert(m, key, f(x, x'))
+ (* end case *))
+ in
+ foldli ins empty m1
+ end
+ in
+ if (numItems m1 > numItems m2)
+ then intersect f (m1, m2)
+ else intersect (fn (a, b) => f(b, a)) (m2, m1)
+ end
+ fun intersectWithi f (m1, m2) = let
+ (* iterate over the elements of m1, checking for membership in m2 *)
+ fun intersect f (m1, m2) = let
+ fun ins (key, x, m) = (case find(m2, key)
+ of NONE => m
+ | (SOME x') => insert(m, key, f(key, x, x'))
+ (* end case *))
+ in
+ foldli ins empty m1
+ end
+ in
+ if (numItems m1 > numItems m2)
+ then intersect f (m1, m2)
+ else intersect (fn (k, a, b) => f(k, b, a)) (m2, m1)
+ end
+
+ fun mergeWith f (m1, m2) = let
+ fun merge ([], [], m) = m
+ | merge ((k1, x1)::r1, [], m) = mergef (k1, SOME x1, NONE, r1, [], m)
+ | merge ([], (k2, x2)::r2, m) = mergef (k2, NONE, SOME x2, [], r2, m)
+ | merge (m1 as ((k1, x1)::r1), m2 as ((k2, x2)::r2), m) = (
+ case Key.compare (k1, k2)
+ of LESS => mergef (k1, SOME x1, NONE, r1, m2, m)
+ | EQUAL => mergef (k1, SOME x1, SOME x2, r1, r2, m)
+ | GREATER => mergef (k2, NONE, SOME x2, m1, r2, m)
+ (* end case *))
+ and mergef (k, x1, x2, r1, r2, m) = (case f (x1, x2)
+ of NONE => merge (r1, r2, m)
+ | SOME y => merge (r1, r2, insert(m, k, y))
+ (* end case *))
+ in
+ merge (listItemsi m1, listItemsi m2, empty)
+ end
+ fun mergeWithi f (m1, m2) = let
+ fun merge ([], [], m) = m
+ | merge ((k1, x1)::r1, [], m) = mergef (k1, SOME x1, NONE, r1, [], m)
+ | merge ([], (k2, x2)::r2, m) = mergef (k2, NONE, SOME x2, [], r2, m)
+ | merge (m1 as ((k1, x1)::r1), m2 as ((k2, x2)::r2), m) = (
+ case Key.compare (k1, k2)
+ of LESS => mergef (k1, SOME x1, NONE, r1, m2, m)
+ | EQUAL => mergef (k1, SOME x1, SOME x2, r1, r2, m)
+ | GREATER => mergef (k2, NONE, SOME x2, m1, r2, m)
+ (* end case *))
+ and mergef (k, x1, x2, r1, r2, m) = (case f (k, x1, x2)
+ of NONE => merge (r1, r2, m)
+ | SOME y => merge (r1, r2, insert(m, k, y))
+ (* end case *))
+ in
+ merge (listItemsi m1, listItemsi m2, empty)
+ end
+
+ (* this is a generic implementation of filter. It should
+ * be specialized to the data-structure at some point.
+ *)
+ fun filter predFn m = let
+ fun f (key, item, m) = if predFn item
+ then insert(m, key, item)
+ else m
+ in
+ foldli f empty m
+ end
+ fun filteri predFn m = let
+ fun f (key, item, m) = if predFn(key, item)
+ then insert(m, key, item)
+ else m
+ in
+ foldli f empty m
+ end
+
+ (* this is a generic implementation of mapPartial. It should
+ * be specialized to the data-structure at some point.
+ *)
+ fun mapPartial f m = let
+ fun g (key, item, m) = (case f item
+ of NONE => m
+ | (SOME item') => insert(m, key, item')
+ (* end case *))
+ in
+ foldli g empty m
+ end
+ fun mapPartiali f m = let
+ fun g (key, item, m) = (case f(key, item)
+ of NONE => m
+ | (SOME item') => insert(m, key, item')
+ (* end case *))
+ in
+ foldli g empty m
+ end
+
+ end (* functor BinaryMapFn *)
--- /dev/null
+(* binary-set-fn.sml
+ *
+ * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
+ *
+ * This code was adapted from Stephen Adams' binary tree implementation
+ * of applicative integer sets.
+ *
+ * Copyright 1992 Stephen Adams.
+ *
+ * This software may be used freely provided that:
+ * 1. This copyright notice is attached to any copy, derived work,
+ * or work including all or part of this software.
+ * 2. Any derived work must contain a prominent notice stating that
+ * it has been altered from the original.
+ *
+ * Name(s): Stephen Adams.
+ * Department, Institution: Electronics & Computer Science,
+ * University of Southampton
+ * Address: Electronics & Computer Science
+ * University of Southampton
+ * Southampton SO9 5NH
+ * Great Britian
+ * E-mail: sra@ecs.soton.ac.uk
+ *
+ * Comments:
+ *
+ * 1. The implementation is based on Binary search trees of Bounded
+ * Balance, similar to Nievergelt & Reingold, SIAM J. Computing
+ * 2(1), March 1973. The main advantage of these trees is that
+ * they keep the size of the tree in the node, giving a constant
+ * time size operation.
+ *
+ * 2. The bounded balance criterion is simpler than N&R's alpha.
+ * Simply, one subtree must not have more than `weight' times as
+ * many elements as the opposite subtree. Rebalancing is
+ * guaranteed to reinstate the criterion for weight>2.23, but
+ * the occasional incorrect behaviour for weight=2 is not
+ * detrimental to performance.
+ *
+ * 3. There are two implementations of union. The default,
+ * hedge_union, is much more complex and usually 20% faster. I
+ * am not sure that the performance increase warrants the
+ * complexity (and time it took to write), but I am leaving it
+ * in for the competition. It is derived from the original
+ * union by replacing the split_lt(gt) operations with a lazy
+ * version. The `obvious' version is called old_union.
+ *
+ * 4. Most time is spent in T', the rebalancing constructor. If my
+ * understanding of the output of *<file> in the sml batch
+ * compiler is correct then the code produced by NJSML 0.75
+ * (sparc) for the final case is very disappointing. Most
+ * invocations fall through to this case and most of these cases
+ * fall to the else part, i.e. the plain contructor,
+ * T(v,ln+rn+1,l,r). The poor code allocates a 16 word vector
+ * and saves lots of registers into it. In the common case it
+ * then retrieves a few of the registers and allocates the 5
+ * word T node. The values that it retrieves were live in
+ * registers before the massive save.
+ *
+ * Modified to functor to support general ordered values
+ *)
+
+functor BinarySetFn (K : ORD_KEY) : ORD_SET =
+ struct
+
+ structure Key = K
+
+ type item = K.ord_key
+
+ datatype set
+ = E
+ | T of {
+ elt : item,
+ cnt : int,
+ left : set,
+ right : set
+ }
+
+ fun numItems E = 0
+ | numItems (T{cnt,...}) = cnt
+
+ fun isEmpty E = true
+ | isEmpty _ = false
+
+ fun mkT(v,n,l,r) = T{elt=v,cnt=n,left=l,right=r}
+
+ (* N(v,l,r) = T(v,1+numItems(l)+numItems(r),l,r) *)
+ fun N(v,E,E) = mkT(v,1,E,E)
+ | N(v,E,r as T{cnt=n,...}) = mkT(v,n+1,E,r)
+ | N(v,l as T{cnt=n,...}, E) = mkT(v,n+1,l,E)
+ | N(v,l as T{cnt=n,...}, r as T{cnt=m,...}) = mkT(v,n+m+1,l,r)
+
+ fun single_L (a,x,T{elt=b,left=y,right=z,...}) = N(b,N(a,x,y),z)
+ | single_L _ = raise Match
+ fun single_R (b,T{elt=a,left=x,right=y,...},z) = N(a,x,N(b,y,z))
+ | single_R _ = raise Match
+ fun double_L (a,w,T{elt=c,left=T{elt=b,left=x,right=y,...},right=z,...}) =
+ N(b,N(a,w,x),N(c,y,z))
+ | double_L _ = raise Match
+ fun double_R (c,T{elt=a,left=w,right=T{elt=b,left=x,right=y,...},...},z) =
+ N(b,N(a,w,x),N(c,y,z))
+ | double_R _ = raise Match
+
+ (*
+ ** val weight = 3
+ ** fun wt i = weight * i
+ *)
+ fun wt (i : int) = i + i + i
+
+ fun T' (v,E,E) = mkT(v,1,E,E)
+ | T' (v,E,r as T{left=E,right=E,...}) = mkT(v,2,E,r)
+ | T' (v,l as T{left=E,right=E,...},E) = mkT(v,2,l,E)
+
+ | T' (p as (_,E,T{left=T _,right=E,...})) = double_L p
+ | T' (p as (_,T{left=E,right=T _,...},E)) = double_R p
+
+ (* these cases almost never happen with small weight*)
+ | T' (p as (_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) =
+ if ln<rn then single_L p else double_L p
+ | T' (p as (_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) =
+ if ln>rn then single_R p else double_R p
+
+ | T' (p as (_,E,T{left=E,...})) = single_L p
+ | T' (p as (_,T{right=E,...},E)) = single_R p
+
+ | T' (p as (v,l as T{elt=lv,cnt=ln,left=ll,right=lr},
+ r as T{elt=rv,cnt=rn,left=rl,right=rr})) =
+ if rn >= wt ln (*right is too big*)
+ then
+ let val rln = numItems rl
+ val rrn = numItems rr
+ in
+ if rln < rrn then single_L p else double_L p
+ end
+ else if ln >= wt rn (*left is too big*)
+ then
+ let val lln = numItems ll
+ val lrn = numItems lr
+ in
+ if lrn < lln then single_R p else double_R p
+ end
+ else mkT(v,ln+rn+1,l,r)
+
+ fun add (E,x) = mkT(x,1,E,E)
+ | add (set as T{elt=v,left=l,right=r,cnt},x) =
+ case K.compare(x,v) of
+ LESS => T'(v,add(l,x),r)
+ | GREATER => T'(v,l,add(r,x))
+ | EQUAL => mkT(x,cnt,l,r)
+ fun add' (s, x) = add(x, s)
+
+ fun concat3 (E,v,r) = add(r,v)
+ | concat3 (l,v,E) = add(l,v)
+ | concat3 (l as T{elt=v1,cnt=n1,left=l1,right=r1}, v,
+ r as T{elt=v2,cnt=n2,left=l2,right=r2}) =
+ if wt n1 < n2 then T'(v2,concat3(l,v,l2),r2)
+ else if wt n2 < n1 then T'(v1,l1,concat3(r1,v,r))
+ else N(v,l,r)
+
+ fun split_lt (E,x) = E
+ | split_lt (T{elt=v,left=l,right=r,...},x) =
+ case K.compare(v,x) of
+ GREATER => split_lt(l,x)
+ | LESS => concat3(l,v,split_lt(r,x))
+ | _ => l
+
+ fun split_gt (E,x) = E
+ | split_gt (T{elt=v,left=l,right=r,...},x) =
+ case K.compare(v,x) of
+ LESS => split_gt(r,x)
+ | GREATER => concat3(split_gt(l,x),v,r)
+ | _ => r
+
+ fun min (T{elt=v,left=E,...}) = v
+ | min (T{left=l,...}) = min l
+ | min _ = raise Match
+
+ fun delmin (T{left=E,right=r,...}) = r
+ | delmin (T{elt=v,left=l,right=r,...}) = T'(v,delmin l,r)
+ | delmin _ = raise Match
+
+ fun delete' (E,r) = r
+ | delete' (l,E) = l
+ | delete' (l,r) = T'(min r,l,delmin r)
+
+ fun concat (E, s) = s
+ | concat (s, E) = s
+ | concat (t1 as T{elt=v1,cnt=n1,left=l1,right=r1},
+ t2 as T{elt=v2,cnt=n2,left=l2,right=r2}) =
+ if wt n1 < n2 then T'(v2,concat(t1,l2),r2)
+ else if wt n2 < n1 then T'(v1,l1,concat(r1,t2))
+ else T'(min t2,t1, delmin t2)
+
+
+ local
+ fun trim (lo,hi,E) = E
+ | trim (lo,hi,s as T{elt=v,left=l,right=r,...}) =
+ if K.compare(v,lo) = GREATER
+ then if K.compare(v,hi) = LESS then s else trim(lo,hi,l)
+ else trim(lo,hi,r)
+
+ fun uni_bd (s,E,_,_) = s
+ | uni_bd (E,T{elt=v,left=l,right=r,...},lo,hi) =
+ concat3(split_gt(l,lo),v,split_lt(r,hi))
+ | uni_bd (T{elt=v,left=l1,right=r1,...},
+ s2 as T{elt=v2,left=l2,right=r2,...},lo,hi) =
+ concat3(uni_bd(l1,trim(lo,v,s2),lo,v),
+ v,
+ uni_bd(r1,trim(v,hi,s2),v,hi))
+ (* inv: lo < v < hi *)
+
+ (* all the other versions of uni and trim are
+ * specializations of the above two functions with
+ * lo=-infinity and/or hi=+infinity
+ *)
+
+ fun trim_lo (_, E) = E
+ | trim_lo (lo,s as T{elt=v,right=r,...}) =
+ case K.compare(v,lo) of
+ GREATER => s
+ | _ => trim_lo(lo,r)
+
+ fun trim_hi (_, E) = E
+ | trim_hi (hi,s as T{elt=v,left=l,...}) =
+ case K.compare(v,hi) of
+ LESS => s
+ | _ => trim_hi(hi,l)
+
+ fun uni_hi (s,E,_) = s
+ | uni_hi (E,T{elt=v,left=l,right=r,...},hi) =
+ concat3(l,v,split_lt(r,hi))
+ | uni_hi (T{elt=v,left=l1,right=r1,...},
+ s2 as T{elt=v2,left=l2,right=r2,...},hi) =
+ concat3(uni_hi(l1,trim_hi(v,s2),v),v,uni_bd(r1,trim(v,hi,s2),v,hi))
+
+ fun uni_lo (s,E,_) = s
+ | uni_lo (E,T{elt=v,left=l,right=r,...},lo) =
+ concat3(split_gt(l,lo),v,r)
+ | uni_lo (T{elt=v,left=l1,right=r1,...},
+ s2 as T{elt=v2,left=l2,right=r2,...},lo) =
+ concat3(uni_bd(l1,trim(lo,v,s2),lo,v),v,uni_lo(r1,trim_lo(v,s2),v))
+
+ fun uni (s,E) = s
+ | uni (E,s) = s
+ | uni (T{elt=v,left=l1,right=r1,...},
+ s2 as T{elt=v2,left=l2,right=r2,...}) =
+ concat3(uni_hi(l1,trim_hi(v,s2),v), v, uni_lo(r1,trim_lo(v,s2),v))
+
+ in
+ val hedge_union = uni
+ end
+
+ (* The old_union version is about 20% slower than
+ * hedge_union in most cases
+ *)
+ fun old_union (E,s2) = s2
+ | old_union (s1,E) = s1
+ | old_union (T{elt=v,left=l,right=r,...},s2) =
+ let val l2 = split_lt(s2,v)
+ val r2 = split_gt(s2,v)
+ in
+ concat3(old_union(l,l2),v,old_union(r,r2))
+ end
+
+ val empty = E
+ fun singleton x = T{elt=x,cnt=1,left=E,right=E}
+
+ fun addList (s,l) = List.foldl (fn (i,s) => add(s,i)) s l
+
+ val add = add
+
+ fun member (set, x) = let
+ fun pk E = false
+ | pk (T{elt=v, left=l, right=r, ...}) = (
+ case K.compare(x,v)
+ of LESS => pk l
+ | EQUAL => true
+ | GREATER => pk r
+ (* end case *))
+ in
+ pk set
+ end
+
+ local
+ (* true if every item in t is in t' *)
+ fun treeIn (t,t') = let
+ fun isIn E = true
+ | isIn (T{elt,left=E,right=E,...}) = member(t',elt)
+ | isIn (T{elt,left,right=E,...}) =
+ member(t',elt) andalso isIn left
+ | isIn (T{elt,left=E,right,...}) =
+ member(t',elt) andalso isIn right
+ | isIn (T{elt,left,right,...}) =
+ member(t',elt) andalso isIn left andalso isIn right
+ in
+ isIn t
+ end
+ in
+ fun isSubset (E,_) = true
+ | isSubset (_,E) = false
+ | isSubset (t as T{cnt=n,...},t' as T{cnt=n',...}) =
+ (n<=n') andalso treeIn (t,t')
+
+ fun equal (E,E) = true
+ | equal (t as T{cnt=n,...},t' as T{cnt=n',...}) =
+ (n=n') andalso treeIn (t,t')
+ | equal _ = false
+ end
+
+ local
+ fun next ((t as T{right, ...})::rest) = (t, left(right, rest))
+ | next _ = (E, [])
+ and left (E, rest) = rest
+ | left (t as T{left=l, ...}, rest) = left(l, t::rest)
+ in
+ fun compare (s1, s2) = let
+ fun cmp (t1, t2) = (case (next t1, next t2)
+ of ((E, _), (E, _)) => EQUAL
+ | ((E, _), _) => LESS
+ | (_, (E, _)) => GREATER
+ | ((T{elt=e1, ...}, r1), (T{elt=e2, ...}, r2)) => (
+ case Key.compare(e1, e2)
+ of EQUAL => cmp (r1, r2)
+ | order => order
+ (* end case *))
+ (* end case *))
+ in
+ cmp (left(s1, []), left(s2, []))
+ end
+ end
+
+ fun delete (E,x) = raise LibBase.NotFound
+ | delete (set as T{elt=v,left=l,right=r,...},x) =
+ case K.compare(x,v) of
+ LESS => T'(v,delete(l,x),r)
+ | GREATER => T'(v,l,delete(r,x))
+ | _ => delete'(l,r)
+
+ val union = hedge_union
+
+ fun intersection (E, _) = E
+ | intersection (_, E) = E
+ | intersection (s, T{elt=v,left=l,right=r,...}) = let
+ val l2 = split_lt(s,v)
+ val r2 = split_gt(s,v)
+ in
+ if member(s,v)
+ then concat3(intersection(l2,l),v,intersection(r2,r))
+ else concat(intersection(l2,l),intersection(r2,r))
+ end
+
+ fun difference (E,s) = E
+ | difference (s,E) = s
+ | difference (s, T{elt=v,left=l,right=r,...}) =
+ let val l2 = split_lt(s,v)
+ val r2 = split_gt(s,v)
+ in
+ concat(difference(l2,l),difference(r2,r))
+ end
+
+ fun map f set = let
+ fun map'(acc, E) = acc
+ | map'(acc, T{elt,left,right,...}) =
+ map' (add (map' (acc, left), f elt), right)
+ in
+ map' (E, set)
+ end
+
+ fun app apf =
+ let fun apply E = ()
+ | apply (T{elt,left,right,...}) =
+ (apply left;apf elt; apply right)
+ in
+ apply
+ end
+
+ fun foldl f b set = let
+ fun foldf (E, b) = b
+ | foldf (T{elt,left,right,...}, b) =
+ foldf (right, f(elt, foldf (left, b)))
+ in
+ foldf (set, b)
+ end
+
+ fun foldr f b set = let
+ fun foldf (E, b) = b
+ | foldf (T{elt,left,right,...}, b) =
+ foldf (left, f(elt, foldf (right, b)))
+ in
+ foldf (set, b)
+ end
+
+ fun listItems set = foldr (op::) [] set
+
+ fun filter pred set =
+ foldl (fn (item, s) => if (pred item) then add(s, item) else s)
+ empty set
+
+ fun partition pred set =
+ foldl
+ (fn (item, (s1, s2)) =>
+ if (pred item) then (add(s1, item), s2) else (s1, add(s2, item))
+ )
+ (empty, empty) set
+
+ fun find p E = NONE
+ | find p (T{elt,left,right,...}) = (case find p left
+ of NONE => if (p elt)
+ then SOME elt
+ else find p right
+ | a => a
+ (* end case *))
+
+ fun exists p E = false
+ | exists p (T{elt, left, right,...}) =
+ (exists p left) orelse (p elt) orelse (exists p right)
+
+ end (* BinarySetFn *)
--- /dev/null
+(* lib-base-sig.sml
+ *
+ * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
+ *)
+
+signature LIB_BASE =
+ sig
+
+ exception Unimplemented of string
+ (* raised to report unimplemented features *)
+ exception Impossible of string
+ (* raised to report internal errors *)
+
+ exception NotFound
+ (* raised by searching operations *)
+
+ val failure : {module : string, func : string, msg : string} -> 'a
+ (* raise the exception Fail with a standard format message. *)
+
+ val version : {date : string, system : string, version_id : int list}
+ val banner : string
+
+ end (* LIB_BASE *)
+
--- /dev/null
+(* lib-base.sml
+ *
+ * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
+ *)
+
+structure LibBase : LIB_BASE =
+ struct
+
+ (* raised to report unimplemented features *)
+ exception Unimplemented of string
+
+ (* raised to report internal errors *)
+ exception Impossible of string
+
+ (* raised by searching operations *)
+ exception NotFound
+
+ (* raise the exception Fail with a standard format message. *)
+ fun failure {module, func, msg} =
+ raise (Fail(concat[module, ".", func, ": ", msg]))
+
+ val version = {
+ date = "June 1, 1996",
+ system = "SML/NJ Library",
+ version_id = [1, 0]
+ }
+
+ fun f ([], l) = l
+ | f ([x : int], l) = (Int.toString x)::l
+ | f (x::r, l) = (Int.toString x) :: "." :: f(r, l)
+
+ val banner = concat (
+ #system version :: ", Version " ::
+ f (#version_id version, [", ", #date version]))
+
+ end (* LibBase *)
+
--- /dev/null
+(* ord-key-sig.sml
+ *
+ * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
+ *
+ * Abstract linearly ordered keys.
+ *
+ *)
+
+signature ORD_KEY =
+ sig
+ type ord_key
+
+ val compare : ord_key * ord_key -> order
+
+ end (* ORD_KEY *)
--- /dev/null
+(* ord-map-sig.sml
+ *
+ * COPYRIGHT (c) 1996 by AT&T Research. See COPYRIGHT file for details.
+ *
+ * Abstract signature of an applicative-style finite maps (dictionaries)
+ * structure over ordered monomorphic keys.
+ *)
+
+signature ORD_MAP =
+ sig
+
+ structure Key : ORD_KEY
+
+ type 'a map
+
+ val empty : 'a map
+ (* The empty map *)
+
+ val isEmpty : 'a map -> bool
+ (* Return true if and only if the map is empty *)
+
+ val singleton : (Key.ord_key * 'a) -> 'a map
+ (* return the specified singleton map *)
+
+ val insert : 'a map * Key.ord_key * 'a -> 'a map
+ val insert' : ((Key.ord_key * 'a) * 'a map) -> 'a map
+ (* Insert an item. *)
+
+ val find : 'a map * Key.ord_key -> 'a option
+ (* Look for an item, return NONE if the item doesn't exist *)
+
+ val inDomain : ('a map * Key.ord_key) -> bool
+ (* return true, if the key is in the domain of the map *)
+
+ val remove : 'a map * Key.ord_key -> 'a map * 'a
+ (* Remove an item, returning new map and value removed.
+ * Raises LibBase.NotFound if not found.
+ *)
+
+ val first : 'a map -> 'a option
+ val firsti : 'a map -> (Key.ord_key * 'a) option
+ (* return the first item in the map (or NONE if it is empty) *)
+
+ val numItems : 'a map -> int
+ (* Return the number of items in the map *)
+
+ val listItems : 'a map -> 'a list
+ val listItemsi : 'a map -> (Key.ord_key * 'a) list
+ (* Return an ordered list of the items (and their keys) in the map. *)
+
+ val listKeys : 'a map -> Key.ord_key list
+ (* return an ordered list of the keys in the map. *)
+
+ val collate : ('a * 'a -> order) -> ('a map * 'a map) -> order
+ (* given an ordering on the map's range, return an ordering
+ * on the map.
+ *)
+
+ val unionWith : ('a * 'a -> 'a) -> ('a map * 'a map) -> 'a map
+ val unionWithi : (Key.ord_key * 'a * 'a -> 'a) -> ('a map * 'a map) -> 'a map
+ (* return a map whose domain is the union of the domains of the two input
+ * maps, using the supplied function to define the map on elements that
+ * are in both domains.
+ *)
+
+ val intersectWith : ('a * 'b -> 'c) -> ('a map * 'b map) -> 'c map
+ val intersectWithi : (Key.ord_key * 'a * 'b -> 'c) -> ('a map * 'b map) -> 'c map
+ (* return a map whose domain is the intersection of the domains of the
+ * two input maps, using the supplied function to define the range.
+ *)
+
+ val mergeWith : ('a option * 'b option -> 'c option)
+ -> ('a map * 'b map) -> 'c map
+ val mergeWithi : (Key.ord_key * 'a option * 'b option -> 'c option)
+ -> ('a map * 'b map) -> 'c map
+ (* merge two maps using the given function to control the merge. For
+ * each key k in the union of the two maps domains, the function
+ * is applied to the image of the key under the map. If the function
+ * returns SOME y, then (k, y) is added to the resulting map.
+ *)
+
+ val app : ('a -> unit) -> 'a map -> unit
+ val appi : ((Key.ord_key * 'a) -> unit) -> 'a map -> unit
+ (* Apply a function to the entries of the map in map order. *)
+
+ val map : ('a -> 'b) -> 'a map -> 'b map
+ val mapi : (Key.ord_key * 'a -> 'b) -> 'a map -> 'b map
+ (* Create a new map by applying a map function to the
+ * name/value pairs in the map.
+ *)
+
+ val foldl : ('a * 'b -> 'b) -> 'b -> 'a map -> 'b
+ val foldli : (Key.ord_key * 'a * 'b -> 'b) -> 'b -> 'a map -> 'b
+ (* Apply a folding function to the entries of the map
+ * in increasing map order.
+ *)
+
+ val foldr : ('a * 'b -> 'b) -> 'b -> 'a map -> 'b
+ val foldri : (Key.ord_key * 'a * 'b -> 'b) -> 'b -> 'a map -> 'b
+ (* Apply a folding function to the entries of the map
+ * in decreasing map order.
+ *)
+
+ val filter : ('a -> bool) -> 'a map -> 'a map
+ val filteri : (Key.ord_key * 'a -> bool) -> 'a map -> 'a map
+ (* Filter out those elements of the map that do not satisfy the
+ * predicate. The filtering is done in increasing map order.
+ *)
+
+ val mapPartial : ('a -> 'b option) -> 'a map -> 'b map
+ val mapPartiali : (Key.ord_key * 'a -> 'b option) -> 'a map -> 'b map
+ (* map a partial function over the elements of a map in increasing
+ * map order.
+ *)
+
+ end (* ORD_MAP *)
--- /dev/null
+(* ordset-sig.sml
+ *
+ * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details.
+ *
+ * Signature for a set of values with an order relation.
+ *)
+
+signature ORD_SET =
+ sig
+
+ structure Key : ORD_KEY
+
+ type item = Key.ord_key
+ type set
+
+ val empty : set
+ (* The empty set *)
+
+ val singleton : item -> set
+ (* Create a singleton set *)
+
+ val add : set * item -> set
+ val add' : (item * set) -> set
+ (* Insert an item. *)
+
+ val addList : set * item list -> set
+ (* Insert items from list. *)
+
+ val delete : set * item -> set
+ (* Remove an item. Raise NotFound if not found. *)
+
+ val member : set * item -> bool
+ (* Return true if and only if item is an element in the set *)
+
+ val isEmpty : set -> bool
+ (* Return true if and only if the set is empty *)
+
+ val equal : (set * set) -> bool
+ (* Return true if and only if the two sets are equal *)
+
+ val compare : (set * set) -> order
+ (* does a lexical comparison of two sets *)
+
+ val isSubset : (set * set) -> bool
+ (* Return true if and only if the first set is a subset of the second *)
+
+ val numItems : set -> int
+ (* Return the number of items in the table *)
+
+ val listItems : set -> item list
+ (* Return an ordered list of the items in the set *)
+
+ val union : set * set -> set
+ (* Union *)
+
+ val intersection : set * set -> set
+ (* Intersection *)
+
+ val difference : set * set -> set
+ (* Difference *)
+
+ val map : (item -> item) -> set -> set
+ (* Create a new set by applying a map function to the elements
+ * of the set.
+ *)
+
+ val app : (item -> unit) -> set -> unit
+ (* Apply a function to the entries of the set
+ * in increasing order
+ *)
+
+ val foldl : (item * 'b -> 'b) -> 'b -> set -> 'b
+ (* Apply a folding function to the entries of the set
+ * in increasing order
+ *)
+
+ val foldr : (item * 'b -> 'b) -> 'b -> set -> 'b
+ (* Apply a folding function to the entries of the set
+ * in decreasing order
+ *)
+
+ val partition : (item -> bool) -> set -> (set * set)
+
+ val filter : (item -> bool) -> set -> set
+
+ val exists : (item -> bool) -> set -> bool
+
+ val find : (item -> bool) -> set -> item option
+
+ end (* ORD_SET *)
--- /dev/null
+Group is
+ lib-base-sig.sml
+ lib-base.sml
+ ord-key-sig.sml
+ ord-map-sig.sml
+ binary-map-fn.sml
+ ord-set-sig.sml
+ binary-set-fn.sml
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Utility functions *)
+
+signature UTIL =
+sig
+ val impLoop : (unit -> 'a) -> ('a -> bool) -> ('a * 'b -> 'b) -> 'b -> unit
+ (* (impLoop next stop body init) repeatedly executes next until stop returns
+ * true on the result. Running state is kept in the style of foldl, with
+ * the state for the next iteration being determiend by calling body with
+ * the most recent next return and the current state.
+ *)
+
+ val ioLoop : (unit -> string) -> (string * 'b -> 'b) -> 'b -> unit
+ (* impLoop specialized to work with TextIO.inputLine, where a return of ""
+ * indicates end-of-file.
+ *)
+ val ioOptLoop : (unit -> string option) -> (string * 'b -> 'b) -> 'b -> unit
+ (* Like ioLoop, but with NONE as sentinel value. *)
+
+ val isIdent : char -> bool
+ (* Is the character a valid part of an identifier? (lowercase letter or
+ * digit?
+ *)
+
+ val validHost : string -> bool
+ (* Valid Internet hostname with no periods? *)
+ val validDomain : string -> bool
+ (* Valid domain name? *)
+ val validUser : string -> bool
+ (* Valid UNIX username? *)
+ val validEmail : string -> bool
+ (* Valid e-mail address? *)
+ val isTmp : string -> bool
+ (* Is the name of a temporary file generated by an editor? *)
+ val validIp : string -> bool
+ (* Is a valid IPv4 address? *)
+
+ val trimLast : string -> string
+ (* Remove the last character from a string *)
+
+ val toDir : string -> string
+ (* Translates a domain name into a fileystem path *)
+
+ val checkPath : StringSet.set * string -> bool
+ (* Given a set of valid path bases and a path, is it allowable? *)
+ val resolveAddr : string StringMap.map * string -> string
+ (* Determine the value of an address field that may include variables.
+ * Check that the final result is a validIp. *)
+ val resolveDomain : string StringMap.map * string -> string
+ (* Determine the value of a domain field that may include variables.
+ * Check that the final result is a validDomain. *)
+end
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Utility functions *)
+
+structure Util :> UTIL =
+struct
+ fun impLoop next stop body init =
+ let
+ fun loop state =
+ let
+ val v = next ()
+ in
+ if stop v then
+ ()
+ else
+ loop (body (v, state))
+ end
+ in
+ loop init
+ end
+
+ fun ioLoop next body init = impLoop next (fn s => s = "") body init
+ fun ioOptLoop next body init =
+ let
+ fun loop state =
+ case next () of
+ NONE => ()
+ | SOME v => loop (body (v, state))
+ in
+ loop init
+ end
+
+ fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
+
+ fun validHost s =
+ size s > 0 andalso size s < 20 andalso List.all isIdent (String.explode s)
+
+ fun validDomain s =
+ size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
+
+ fun validUser s =
+ size s > 0 andalso size s < 20 andalso List.all
+ (fn ch => isIdent ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
+ (String.explode s)
+
+ fun validEmail s =
+ (case String.fields (fn ch => ch = #"@") s of
+ [user, host] => validUser user andalso validDomain host
+ | _ => false)
+
+ fun isTmp s =
+ List.exists (fn ch => ch = #"#" orelse ch = #"~") (String.explode s)
+
+ fun validIp s =
+ (case map Int.fromString (String.fields (fn ch => ch = #".") s) of
+ [SOME n1, SOME n2, SOME n3, SOME n4] =>
+ n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
+ | _ => false)
+
+ fun trimLast s =
+ if size s = 0 then
+ s
+ else
+ String.substring (s, 0, size s - 1)
+
+ fun toDir s =
+ foldr (fn (a, s) => s ^ "/" ^ a) "" (String.tokens (fn ch => ch = #".") s)
+
+ fun checkPath (paths, path) =
+ StringSet.exists (fn pref => path = pref orelse (size path >= size pref + 2 andalso substring (path, 0, size pref) = pref
+ andalso String.sub (path, size pref) = #"/")) paths
+ andalso List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
+
+ fun resolveAddr (vars, s) =
+ if validIp s then
+ s
+ else
+ (case StringMap.find (vars, s) of
+ NONE => ""
+ | SOME v =>
+ if validIp v then
+ v
+ else
+ "")
+
+ fun resolveDomain (vars, s) =
+ if validDomain s then
+ s
+ else
+ (case StringMap.find (vars, s) of
+ NONE => ""
+ | SOME v =>
+ if validDomain v then
+ v
+ else
+ "")
+end
+
--- /dev/null
+CM
+config.sml
\ No newline at end of file
--- /dev/null
+VIRTUAL MAILBOXES FOR COURIER IMAP
+
+
+Here are some simple tools for managing virtual e-mailboxes for
+Courier IMAP (http://www.inter7.com/courierimap/courierimap.html).
+
+A short sample session should demonstrate how to use the vmail and
+reloadusers command line tools:
+
+% vmail your.domain add new.user
+Password: password
+Reenter password: password
+Mailbox created.
+
+% vmail your.domain list
+new.user
+
+% vmail your.domain passwd new.user
+Password: password'
+Reenter password: password'
+Password set.
+
+% reloadusers
+
+After this, where mailboxDir is the directory set in config.sml, a
+Maildir mailbox exists in mailboxDir/your.domain/new.user, and
+login/password data for Courier is in the directories/files given in
+config.sml. You must set up an MTA to properly deliver mail to these
+mailboxes for this to be useful.
+
+vmail only allows a user to administer virtual mailboxes for a domain
+whose directory in the domtool tree the user's current group has write
+access to. Thus, it is important to maintain g+w in these directories
+for this to work.
+
+Actually, this only matters when you use a
+sudo-based solution like mentioned in the main README file. You might
+be able to find a better way of doing things. At hcoop, we have a
+'vmail' user that owns the mailbox directory. Users are allowed via
+sudo to run vmail as user vmail, and user vmail is allowed to run the
+Courier userdb and userdbpw programs as root. All domtool users are
+allowed to run reloadusers as root.
+
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Some options you might want to change *)
+
+structure VmailConfig =
+struct
+ val mailboxDir = "/home/vmail"
+ (* Location of virtual mailboxes *)
+
+ val courierDir = "/usr/lib/courier-imap"
+ (* Base of Courier IMAP directory tree *)
+
+ val userdbDir = "/etc/userdb"
+ (* Directory for storing userdb info *)
+
+ val postReload = "chown mail.mail /etc/userdbshadow.dat"
+ (* Command to run after reloading userdb data *)
+end
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+val _ = OS.Process.exit (Vmail.main (CommandLine.arguments ()))
\ No newline at end of file
--- /dev/null
+Group is
+ config.sml
+
+ reloadusers.sig
+ reloadusers.sml
+ reloadusers.main.sml
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+val _ = OS.Process.exit (Reloadusers.main ())
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+signature RELOADUSERS =
+sig
+ val main : unit -> unit
+end
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Utility to reload Courier IMAP data after modifying virtual mailboxes *)
+
+structure Reloadusers :> RELOADUSERS =
+struct
+ open VmailConfig
+
+ fun main _ =
+ let
+ val proc = Unix.execute("/bin/sh", ["-c", courierDir ^ "/sbin/pw2userdb"])
+ val (stdout, stdin) = Unix.streamsOf proc
+
+ val outf = TextIO.openOut (userdbDir ^ "/localhost")
+
+ fun loop () =
+ case TextIO.inputLine stdout of
+ "" => ()
+ | line =>
+ let
+ val tokens = String.tokens (fn ch => Char.isSpace ch orelse ch = #"|" orelse ch = #"=") line
+
+ fun findHome (n::v::rest) =
+ if n = "home" then
+ TextIO.output (outf, "|mail=" ^ v ^ "/Maildir")
+ else
+ findHome rest
+ | findHome _ = ()
+ in
+ TextIO.output (outf, String.substring (line, 0, size line - 1));
+ case tokens of
+ first::rest =>
+ (case Int.fromString first of
+ NONE => findHome rest
+ | _ => ())
+ | _ => ();
+ TextIO.output (outf, "\n");
+ loop ()
+ end
+ in
+ loop ();
+ TextIO.closeOut outf;
+ TextIO.closeIn stdout;
+ TextIO.closeOut stdin;
+ Unix.reap proc;
+ if OS.Process.isSuccess (OS.Process.system (courierDir ^ "/sbin/makeuserdb")) then
+ OS.Process.system postReload
+ else
+ (print "Error running makeuserdb\n";
+ OS.Process.failure)
+ end
+end
--- /dev/null
+Group is
+ ../smlnj-lib/sources.cm
+ ../map.sml
+
+ ../config.sml
+ config.sml
+
+ ../util.sig
+ ../util.sml
+
+ vmail.sig
+ vmail.sml
+ main.sml
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+signature VMAIL =
+sig
+ val main : string list -> OS.Process.status
+end
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Administration of Courier IMAP virtual mailboxes *)
+
+structure Vmail :> VMAIL =
+struct
+ open Config VmailConfig Util
+
+ fun main args =
+ case args of
+ domain::rest =>
+ if validDomain domain then
+ let
+ val tooldir = dataDir ^ toDir domain
+ val maildir = mailboxDir ^ "/" ^ domain
+ in
+ if not (Posix.FileSys.access (tooldir, [])) then
+ (print ("Domain not in domtool (would be " ^ tooldir ^ ")\n");
+ OS.Process.failure)
+ else if not (Posix.FileSys.access (tooldir, [Posix.FileSys.A_WRITE])) then
+ (print "Access denied\n";
+ OS.Process.failure)
+ else
+ case rest of
+ ["list"] =>
+ (let
+ val dir = Posix.FileSys.opendir maildir
+
+ fun loop () =
+ case Posix.FileSys.readdir dir of
+ NONE => ()
+ | SOME user => (print (user ^ "\n");
+ loop ())
+ in
+ loop ();
+ Posix.FileSys.closedir dir;
+ OS.Process.success
+ end handle Io => OS.Process.success)
+ | ["add", user] =>
+ if validUser user then
+ let
+ val _ = if Posix.FileSys.access (maildir, []) then
+ ()
+ else
+ ignore (OS.Process.system ("mkdir " ^ maildir))
+
+ val umaildir = maildir ^ "/" ^ user
+ in
+ if Posix.FileSys.access (umaildir, []) then
+ (print "Mailbox already exists\n";
+ OS.Process.failure)
+ else if OS.Process.system (courierDir ^ "/bin/maildirmake " ^ umaildir) = OS.Process.success
+ andalso OS.Process.system (sudo ^ " " ^ courierDir ^ "/sbin/userdb \"" ^ domain ^ "/" ^ user ^ "@" ^ domain ^ "\" set home=/home/vmail mail=/home/vmail/" ^ domain ^ "/" ^ user ^ " uid=1042 gid=1043") = OS.Process.success
+ andalso OS.Process.system (sudo ^ " " ^ courierDir ^ "/sbin/userdbpw | " ^ sudo ^ " " ^ courierDir ^ "/sbin/userdb \"" ^ domain ^ "/" ^ user ^ "@" ^ domain ^ "\" set systempw") = OS.Process.success then
+ (print "Mailbox created\n";
+ OS.Process.success)
+ else
+ (print "Error creating mailbox\n";
+ OS.Process.failure)
+ end
+ else
+ (print "Invalid mailbox name\n";
+ OS.Process.failure)
+ | ["passwd", user] =>
+ if not (validUser user) then
+ (print "Invalid mailbox name\n";
+ OS.Process.failure)
+ else if not (Posix.FileSys.access (maildir ^ "/" ^ user, [])) then
+ (print "Mailbox does not exist\n";
+ OS.Process.failure)
+ else if OS.Process.system (sudo ^ " " ^ courierDir ^ "/sbin/userdbpw | " ^ sudo ^ " " ^ courierDir ^ "/sbin/userdb \"" ^ domain ^ "/" ^ user ^ "@" ^ domain ^ "\" set systempw") = OS.Process.success then
+ (print "Password set\n";
+ OS.Process.success)
+ else
+ (print "Unable to set password\n";
+ OS.Process.failure)
+ | _ => (print "Unknown command\n";
+ OS.Process.failure)
+ end
+ else
+ (print "Invalid domain\n";
+ OS.Process.failure)
+ | _ => (print "Invalid command\n";
+ OS.Process.failure)
+end
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+structure WebpasswdConfig =
+struct
+ (* Paths to needed programs *)
+ val getent = "/usr/bin/getent"
+ val htpasswd = "/usr/bin/htpasswd"
+end
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+val _ = OS.Process.exit (Webpasswd.main ())
\ No newline at end of file
--- /dev/null
+Group is
+ ../config.sml
+ ../apache/config.sml
+ config.sml
+
+ webpasswd.sig
+ webpasswd.sml
+ main.sml
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+signature WEBPASSWD =
+sig
+ val main : unit -> unit
+end
\ No newline at end of file
--- /dev/null
+(*
+Domtool (http://hcoop.sf.net/)
+Copyright (C) 2004 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+(* Utility to let a user set a password in an Apache password file for a user
+ * name matches his UNIX login name. *)
+
+structure Webpasswd :> WEBPASSWD =
+struct
+ open Config ApacheConfig WebpasswdConfig
+
+ fun main () =
+ let
+ val uid = SysWord.toInt (Posix.ProcEnv.uidToWord (Posix.ProcEnv.getuid ()))
+
+ val proc = Unix.execute("/bin/sh", ["-c", getent ^ " passwd " ^
+ Int.toString uid])
+ val (stdout, stdin) = Unix.streamsOf proc
+
+ val name =
+ case String.tokens (fn ch => ch = #":") (TextIO.inputLine stdout) of
+ name::_ => name
+ | _ => raise Fail "Unexpected getent output"
+ in
+ TextIO.closeOut stdin;
+ TextIO.closeIn stdout;
+ if not (OS.Process.isSuccess (Unix.reap proc)) then
+ (print "Error reaping getent\n";
+ OS.Process.failure)
+ else
+ (print ("Update password for " ^ name ^ "\n");
+ OS.Process.system (htpasswd ^ " " ^ passwdFile ^ " \"" ^ name ^ "\""))
+ end
+end
+
HCoop / hcoop / zz_old / domtool.git / commitdiff