HCoop Git - hcoop/domtool2.git/blob

 (* HCoop Domtool (http://hcoop.sourceforge.net/)

  * Copyright (c) 2006-2009, Adam Chlipala

  * Copyright (c) 2012,2013,2014 Clinton Ebadi <clinton@unknownlamer.org>

4 *

5 * This program is free software; you can redistribute it and/or

6 * modify it under the terms of the GNU General Public License

7 * as published by the Free Software Foundation; either version 2

  * of the License, or (at your option) any later version.

9 *

10 * This program is distributed in the hope that it will be useful,

11 * but WITHOUT ANY WARRANTY; without even the implied warranty of

12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

13 * GNU General Public License for more details.

14 *

15 * You should have received a copy of the GNU General Public License

  * along with this program; if not, write to the Free Software

  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

18 *)

20 (* Main interface *)

22 structure Main :> MAIN = struct

24 open Ast MsgTypes Print

26 structure SM = StringMap

 fun init () = Acl.read Config.aclFile

 fun isLib fname = OS.Path.file fname = "lib.dtl"

 fun wrapFile (fname, file) =

     case (isLib fname, file) of

         (true, (comment, ds, SOME e)) =>

35 let

36 val (_, loc) = e

37 in

             (comment, ds, SOME (ELocal (e, (ESkip, loc)), loc))

39 end

40 | _ => file

42 fun check' G fname =

43 let

44 val prog = Parse.parse fname

         val prog = wrapFile (fname, prog)

46 in

47 if !ErrorMsg.anyErrors then

48 G

49 else

50 (if isLib fname then

51 ()

52 else

                  Option.app (Unused.check G) (#3 prog);

54 Tycheck.checkFile G prog)

55 end

57 fun basis () =

58 let

         val _ = ErrorMsg.reset ()

         val dir = Posix.FileSys.opendir Config.libRoot

62 fun loop files =

63 case Posix.FileSys.readdir dir of

64 NONE => (Posix.FileSys.closedir dir;

65 files)

66 | SOME fname =>

67 if String.isSuffix ".dtl" fname then

                     loop (OS.Path.joinDirFile {dir = Config.libRoot,

69 file = fname}

70 :: files)

71 else

72 loop files

74 val files = loop []

         val (_, files) = Order.order NONE files

76 in

77 if !ErrorMsg.anyErrors then

78 Env.empty

79 else

80 (Tycheck.allowExterns ();

              foldl (fn (fname, G) => check' G fname) Env.empty files

82 before Tycheck.disallowExterns ())

83 end

 (* val b = basis () *)

87 fun check G fname =

88 let

         val _ = ErrorMsg.reset ()

         val _ = Env.preTycheck ()

91 in

92 if !ErrorMsg.anyErrors then

93 raise ErrorMsg.Error

94 else

95 let

                 val _ = Tycheck.disallowExterns ()

                 val _ = ErrorMsg.reset ()

98 val prog = Parse.parse fname

                 val prog = wrapFile (fname, prog)

100 in

101 if !ErrorMsg.anyErrors then

102 raise ErrorMsg.Error

103 else

104 let

105 val G' = Tycheck.checkFile G prog

106 in

107 if !ErrorMsg.anyErrors then

108 raise ErrorMsg.Error

109 else

110 (if isLib fname then

111 ()

112 else

                                  Option.app (Unused.check G) (#3 prog);

114 (G', #3 prog))

115 end

116 end

117 end

118

119 fun notTmp s =

     String.sub (s, 0) <> #"."

121 andalso s <> "_darcs"

     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s

123

124 fun setupUser () =

125 let

126 val user =

             case Posix.ProcEnv.getenv "DOMTOOL_USER" of

128 NONE =>

129 let

                     val uid = Posix.ProcEnv.getuid ()

131 in

                     Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)

133 end

134 | SOME user => user

135 in

136 Acl.read Config.aclFile;

137 Domain.setUser user;

138 user

139 end

140

141 fun checkDir' dname =

142 let

143 val b = basis ()

144

145 val dir = Posix.FileSys.opendir dname

146

147 fun loop files =

148 case Posix.FileSys.readdir dir of

149 NONE => (Posix.FileSys.closedir dir;

150 files)

151 | SOME fname =>

152 if notTmp fname then

                     loop (OS.Path.joinDirFile {dir = dname,

154 file = fname}

155 :: files)

156 else

157 loop files

158

159 val files = loop []

         val (_, files) = Order.order (SOME b) files

161 in

162 if !ErrorMsg.anyErrors then

163 raise ErrorMsg.Error

164 else

             (foldl (fn (fname, G) => check' G fname) b files;

166 if !ErrorMsg.anyErrors then

167 raise ErrorMsg.Error

168 else

169 ())

170 end

171

172 fun checkDir dname =

173 (setupUser ();

174 checkDir' dname)

175

176 fun reduce G fname =

177 let

178 val (G, body) = check G fname

179 in

180 if !ErrorMsg.anyErrors then

181 (G, NONE)

182 else

183 case body of

184 SOME body =>

185 let

186 val body' = Reduce.reduceExp G body

187 in

                     (*printd (PD.hovBox (PD.PPS.Rel 0,

                                          [PD.string "Result:",

190 PD.space 1,

191 p_exp body']))*)

192 (G, SOME body')

193 end

194 | _ => (G, NONE)

195 end

196

197 (*(Defaults.eInit ())*)

198

199 val toplevel = Env.initialDynEnvVals Reduce.reduceExp

200

201 fun eval G evs fname =

202 case reduce G fname of

203 (G, SOME body') =>

204 if !ErrorMsg.anyErrors then

205 raise ErrorMsg.Error

206 else

207 let

                 val evs' = Eval.exec' (toplevel G, evs) body'

209 in

210 (G, evs')

211 end

       | (G, NONE) => (G, evs)

213

214 val dispatcher =

     Domain.nodeIp Config.dispatcherName ^ ":" ^ Int.toString Config.dispatcherPort

216

217 val self =

218 "localhost:" ^ Int.toString Config.slavePort

219

220 fun context x =

221 (OpenSSL.context false x)

222 handle e as OpenSSL.OpenSSL s =>

            (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n";

             print ("I looked in: " ^ #1 x ^ "\n");

             print ("Additional information: " ^ s ^ "\n");

226 raise e)

227

228 fun requestContext f =

229 let

230 val user = setupUser ()

231

232 val () = f ()

233

         val context = context (Config.certDir ^ "/" ^ user ^ ".pem",

235 Config.keyDir ^ "/" ^ user ^ "/key.pem",

236 Config.trustStore)

237 in

238 (user, context)

239 end

240

241 fun requestBio' printErr f =

242 let

243 val (user, context) = requestContext f

244 in

         (user, OpenSSL.connect printErr (context, dispatcher))

246 end

247

248 val requestBio = requestBio' true

249

250 fun requestSlaveBio' printErr =

251 let

         val (user, context) = requestContext (fn () => ())

253 in

         (user, OpenSSL.connect printErr (context, self))

255 end

256

 fun requestSlaveBio () = requestSlaveBio' true

258

 fun request (fname, libOpt) =

260 let

         val (user, bio) = requestBio (fn () =>

262 let

263 val env = basis ()

264 val env = case libOpt of

265 NONE => env

266 | SOME lib => #1 (check env lib)

267 in

268 ignore (check env fname)

269 end)

270

271 fun readFile fname =

272 let

273 val inf = TextIO.openIn fname

274

275 fun loop lines =

276 case TextIO.inputLine inf of

                         NONE => String.concat (rev lines)

                       | SOME line => loop (line :: lines)

279 in

280 loop []

281 before TextIO.closeIn inf

282 end

283

284 val code = readFile fname

285 val msg = case libOpt of

286 NONE => MsgConfig code

287 | SOME fname' => MsgMultiConfig [readFile fname', code]

288 in

         Msg.send (bio, msg);

290 case Msg.recv bio of

291 NONE => print "Server closed connection unexpectedly.\n"

292 | SOME m =>

293 case m of

294 MsgOk => print "Configuration succeeded.\n"

               | MsgError s => print ("Configuration failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

297 OpenSSL.close bio

298 end

299 handle ErrorMsg.Error => ()

300

301 fun requestDir dname =

302 let

         val _ = if Posix.FileSys.access (dname, []) then

304 ()

305 else

                     (print ("Can't access " ^ dname ^ ".\n");

307 print "Did you mean to run domtool on a specific file, instead of asking for all\n";

308 print "files in your ~/.domtool directory?\n";

                      OS.Process.exit OS.Process.failure)

310

         val _ = ErrorMsg.reset ()

312

         val (user, bio) = requestBio (fn () => checkDir' dname)

314

315 val b = basis ()

316

317 val dir = Posix.FileSys.opendir dname

318

319 fun loop files =

320 case Posix.FileSys.readdir dir of

321 NONE => (Posix.FileSys.closedir dir;

322 files)

323 | SOME fname =>

324 if notTmp fname then

                     loop (OS.Path.joinDirFile {dir = dname,

326 file = fname}

327 :: files)

328 else

329 loop files

330

331 val files = loop []

         val (_, files) = Order.order (SOME b) files

333

         val _ = if !ErrorMsg.anyErrors then

335 raise ErrorMsg.Error

336 else

337 ()

338

         val codes = map (fn fname =>

340 let

341 val inf = TextIO.openIn fname

342

343 fun loop lines =

344 case TextIO.inputLine inf of

                                         NONE => String.concat (rev lines)

                                       | SOME line => loop (line :: lines)

347 in

348 loop []

349 before TextIO.closeIn inf

350 end) files

351 in

352 if !ErrorMsg.anyErrors then

353 ()

354 else

             (Msg.send (bio, MsgMultiConfig codes);

356 case Msg.recv bio of

357 NONE => print "Server closed connection unexpectedly.\n"

358 | SOME m =>

359 case m of

360 MsgOk => print "Configuration succeeded.\n"

                    | MsgError s => print ("Configuration failed: " ^ s ^ "\n")

                    | _ => print "Unexpected server reply.\n";

363 OpenSSL.close bio)

364 end

365 handle ErrorMsg.Error => ()

366

367 fun requestPing () =

368 let

         val (_, bio) = requestBio' false (fn () => ())

370 in

371 OpenSSL.close bio;

372 OS.Process.success

373 end

374 handle _ => OS.Process.failure

375

376 fun requestShutdown () =

377 let

         val (_, bio) = requestBio (fn () => ())

379 in

         Msg.send (bio, MsgShutdown);

381 case Msg.recv bio of

382 NONE => ()

383 | SOME m =>

384 case m of

385 MsgOk => print "Shutdown begun.\n"

               | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

388 OpenSSL.close bio

389 end

390

391 fun requestSlavePing () =

392 let

         val (_, bio) = requestSlaveBio' false

394 in

395 OpenSSL.close bio;

396 OS.Process.success

397 end

398 handle _ => OS.Process.failure

399

400 fun requestSlaveShutdown () =

401 let

         val (_, bio) = requestSlaveBio ()

403 in

         Msg.send (bio, MsgShutdown);

405 case Msg.recv bio of

406 NONE => ()

407 | SOME m =>

408 case m of

409 MsgOk => print "Shutdown begun.\n"

               | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

412 OpenSSL.close bio

413 end

414

415 fun requestGrant acl =

416 let

         val (user, bio) = requestBio (fn () => ())

418 in

         Msg.send (bio, MsgGrant acl);

420 case Msg.recv bio of

421 NONE => print "Server closed connection unexpectedly.\n"

422 | SOME m =>

423 case m of

424 MsgOk => print "Grant succeeded.\n"

               | MsgError s => print ("Grant failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

427 OpenSSL.close bio

428 end

429

430 fun requestRevoke acl =

431 let

         val (user, bio) = requestBio (fn () => ())

433 in

         Msg.send (bio, MsgRevoke acl);

435 case Msg.recv bio of

436 NONE => print "Server closed connection unexpectedly.\n"

437 | SOME m =>

438 case m of

439 MsgOk => print "Revoke succeeded.\n"

               | MsgError s => print ("Revoke failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

442 OpenSSL.close bio

443 end

444

445 fun requestListPerms user =

446 let

         val (_, bio) = requestBio (fn () => ())

448 in

         Msg.send (bio, MsgListPerms user);

450 (case Msg.recv bio of

              NONE => (print "Server closed connection unexpectedly.\n";

452 NONE)

453 | SOME m =>

454 case m of

455 MsgPerms perms => SOME perms

                | MsgError s => (print ("Listing failed: " ^ s ^ "\n");

457 NONE)

                | _ => (print "Unexpected server reply.\n";

459 NONE))

460 before OpenSSL.close bio

461 end

462

463 fun requestWhoHas perm =

464 let

         val (_, bio) = requestBio (fn () => ())

466 in

         Msg.send (bio, MsgWhoHas perm);

468 (case Msg.recv bio of

              NONE => (print "Server closed connection unexpectedly.\n";

470 NONE)

471 | SOME m =>

472 case m of

473 MsgWhoHasResponse users => SOME users

                | MsgError s => (print ("whohas failed: " ^ s ^ "\n");

475 NONE)

                | _ => (print "Unexpected server reply.\n";

477 NONE))

478 before OpenSSL.close bio

479 end

480

481 fun requestRegen () =

482 let

         val (_, bio) = requestBio (fn () => ())

484 in

         Msg.send (bio, MsgRegenerate);

486 case Msg.recv bio of

487 NONE => print "Server closed connection unexpectedly.\n"

488 | SOME m =>

489 case m of

490 MsgOk => print "Regeneration succeeded.\n"

               | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

493 OpenSSL.close bio

494 end

495

496 fun requestRegenTc () =

497 let

         val (_, bio) = requestBio (fn () => ())

499 in

         Msg.send (bio, MsgRegenerateTc);

501 case Msg.recv bio of

502 NONE => print "Server closed connection unexpectedly.\n"

503 | SOME m =>

504 case m of

505 MsgOk => print "All configuration validated.\n"

               | MsgError s => print ("Configuration validation failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

508 OpenSSL.close bio

509 end

510

511 fun requestRmdom dom =

512 let

         val (_, bio) = requestBio (fn () => ())

514 in

         Msg.send (bio, MsgRmdom dom);

516 case Msg.recv bio of

517 NONE => print "Server closed connection unexpectedly.\n"

518 | SOME m =>

519 case m of

520 MsgOk => print "Removal succeeded.\n"

               | MsgError s => print ("Removal failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

523 OpenSSL.close bio

524 end

525

526 fun requestRmuser user =

527 let

         val (_, bio) = requestBio (fn () => ())

529 in

         Msg.send (bio, MsgRmuser user);

531 case Msg.recv bio of

532 NONE => print "Server closed connection unexpectedly.\n"

533 | SOME m =>

534 case m of

535 MsgOk => print "Removal succeeded.\n"

               | MsgError s => print ("Removal failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

538 OpenSSL.close bio

539 end

540

541 fun requestDbUser dbtype =

542 let

         val (_, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context,

                                         Domain.nodeIp Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)

546 in

         Msg.send (bio, MsgCreateDbUser dbtype);

548 case Msg.recv bio of

549 NONE => print "Server closed connection unexpectedly.\n"

550 | SOME m =>

551 case m of

552 MsgOk => print "Your user has been created.\n"

               | MsgError s => print ("Creation failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

555 OpenSSL.close bio

556 end

557

558 fun requestDbPasswd rc =

559 let

         val (_, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context,

                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)

563 in

         Msg.send (bio, MsgDbPasswd rc);

565 case Msg.recv bio of

566 NONE => print "Server closed connection unexpectedly.\n"

567 | SOME m =>

568 case m of

569 MsgOk => print "Your password has been changed.\n"

               | MsgError s => print ("Password set failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

572 OpenSSL.close bio

573 end

574

575 fun requestDbTable p =

576 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context,

                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)

580 in

         Msg.send (bio, MsgCreateDb p);

582 case Msg.recv bio of

583 NONE => print "Server closed connection unexpectedly.\n"

584 | SOME m =>

585 case m of

                 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")

               | MsgError s => print ("Creation failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

589 OpenSSL.close bio

590 end

591

592 fun requestDbDrop p =

593 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context,

                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)

597 in

         Msg.send (bio, MsgDropDb p);

599 case Msg.recv bio of

600 NONE => print "Server closed connection unexpectedly.\n"

601 | SOME m =>

602 case m of

                 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been dropped.\n")

               | MsgError s => print ("Drop failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

606 OpenSSL.close bio

607 end

608

609 fun requestDbGrant p =

610 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context,

                                         Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)

614 in

         Msg.send (bio, MsgGrantDb p);

616 case Msg.recv bio of

617 NONE => print "Server closed connection unexpectedly.\n"

618 | SOME m =>

619 case m of

                 MsgOk => print ("You've been granted all allowed privileges to database " ^ user ^ "_" ^ #dbname p ^ ".\n")

               | MsgError s => print ("Grant failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

623 OpenSSL.close bio

624 end

625

626 fun requestListMailboxes domain =

627 let

         val (_, bio) = requestBio (fn () => ())

629 in

         Msg.send (bio, MsgListMailboxes domain);

631 (case Msg.recv bio of

632 NONE => Vmail.Error "Server closed connection unexpectedly."

633 | SOME m =>

634 case m of

                  MsgMailboxes users => (Msg.send (bio, MsgOk);

636 Vmail.Listing users)

                | MsgError s => Vmail.Error ("Listing failed: " ^ s)

638 | _ => Vmail.Error "Unexpected server reply.")

639 before OpenSSL.close bio

640 end

641

642 fun requestNewMailbox p =

643 let

         val (_, bio) = requestBio (fn () => ())

645 in

         Msg.send (bio, MsgNewMailbox p);

647 case Msg.recv bio of

648 NONE => print "Server closed connection unexpectedly.\n"

649 | SOME m =>

650 case m of

                 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")

               | MsgError s => print ("Creation failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

654 OpenSSL.close bio

655 end

656

657 fun requestPasswdMailbox p =

658 let

         val (_, bio) = requestBio (fn () => ())

660 in

         Msg.send (bio, MsgPasswdMailbox p);

662 case Msg.recv bio of

663 NONE => print "Server closed connection unexpectedly.\n"

664 | SOME m =>

665 case m of

                 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")

               | MsgError s => print ("Set failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

669 OpenSSL.close bio

670 end

671

672 fun requestPortalPasswdMailbox p =

673 let

         val (_, bio) = requestBio (fn () => ())

675 in

         (Msg.send (bio, MsgPortalPasswdMailbox p);

677 case Msg.recv bio of

              NONE => (print "Server closed connection unexpectedly.\n"; OS.Process.failure)

679 | SOME m =>

680 case m of

                  MsgOk => (print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n");

682 OS.Process.success)

                | MsgError s => (print ("Set failed: " ^ s ^ "\n"); OS.Process.failure)

                | _ => (print "Unexpected server reply.\n"; OS.Process.failure))

685 before OpenSSL.close bio

686 end

687

688 fun requestRmMailbox p =

689 let

         val (_, bio) = requestBio (fn () => ())

691 in

         Msg.send (bio, MsgRmMailbox p);

693 case Msg.recv bio of

694 NONE => print "Server closed connection unexpectedly.\n"

695 | SOME m =>

696 case m of

                 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")

               | MsgError s => print ("Remove failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

700 OpenSSL.close bio

701 end

702

703 fun requestSaQuery addr =

704 let

         val (_, bio) = requestBio (fn () => ())

706 in

         Msg.send (bio, MsgSaQuery addr);

708 (case Msg.recv bio of

709 NONE => print "Server closed connection unexpectedly.\n"

710 | SOME m =>

711 case m of

                  MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "

                                           ^ (if b then "ON" else "OFF") ^ ".\n");

                                    Msg.send (bio, MsgOk))

                | MsgError s => print ("Query failed: " ^ s ^ "\n")

                | _ => print "Unexpected server reply.\n")

717 before OpenSSL.close bio

718 end

719

720 fun requestSaSet p =

721 let

         val (_, bio) = requestBio (fn () => ())

723 in

         Msg.send (bio, MsgSaSet p);

725 case Msg.recv bio of

726 NONE => print "Server closed connection unexpectedly.\n"

727 | SOME m =>

728 case m of

                 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "

                                 ^ (if #2 p then "ON" else "OFF") ^ ".\n")

               | MsgError s => print ("Set failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

733 OpenSSL.close bio

734 end

735

736 fun requestSmtpLog domain =

737 let

         val (_, bio) = requestBio (fn () => ())

739

         val _ = Msg.send (bio, MsgSmtpLogReq domain)

741

742 fun loop () =

743 case Msg.recv bio of

744 NONE => print "Server closed connection unexpectedly.\n"

745 | SOME m =>

746 case m of

747 MsgOk => ()

748 | MsgSmtpLogRes line => (print line;

749 loop ())

                   | MsgError s => print ("Log search failed: " ^ s ^ "\n")

751 | _ => print "Unexpected server reply.\n"

752 in

753 loop ();

754 OpenSSL.close bio

755 end

756

757 fun requestApt {node, pkg} =

758 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then

761 dispatcher

762 else

                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

764

         val _ = Msg.send (bio, MsgQuery (QApt pkg))

766

767 fun loop () =

768 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

770 OS.Process.failure)

771 | SOME m =>

772 case m of

                     MsgYes => (print "Package is installed.\n";

774 OS.Process.success)

                   | MsgNo => (print "Package is not installed.\n";

776 OS.Process.failure)

                   | MsgError s => (print ("APT query failed: " ^ s ^ "\n");

778 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

780 OS.Process.failure)

781 in

782 loop ()

783 before OpenSSL.close bio

784 end

785

786 fun requestAptExists {node, pkg} =

787 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then

790 dispatcher

791 else

                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

793

         val _ = Msg.send (bio, MsgQuery (QAptExists pkg))

795

796 fun loop () =

797 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

799 OS.Process.failure)

800 | SOME m =>

801 case m of

                     MsgAptQuery {section,description}  =>  (print "Package exists.\n";

                                                             print ("Section: " ^ section ^ "\n");

                                                             print ("Description: " ^ description ^ "\n");

805 OS.Process.success)

                   | MsgNo => (print "Package does not exist.\n";

807 OS.Process.failure

                              (* It might be the Wrong Thing (tm) to use MsgNo like this *))

                   | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n");

810 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

812 OS.Process.failure)

813 in

814 loop ()

815 before OpenSSL.close bio

816 end

817

818 fun requestCron {node, uname} =

819 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then

822 dispatcher

823 else

                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

825

         val _ = Msg.send (bio, MsgQuery (QCron uname))

827

828 fun loop () =

829 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

831 OS.Process.failure)

832 | SOME m =>

833 case m of

                     MsgYes => (print "User has cron permissions.\n";

835 OS.Process.success)

                   | MsgNo => (print "User does not have cron permissions.\n";

837 OS.Process.failure)

                   | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");

839 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

841 OS.Process.failure)

842 in

843 loop ()

844 before OpenSSL.close bio

845 end

846

847 fun requestFtp {node, uname} =

848 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then

851 dispatcher

852 else

                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

854

         val _ = Msg.send (bio, MsgQuery (QFtp uname))

856

857 fun loop () =

858 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

860 OS.Process.failure)

861 | SOME m =>

862 case m of

                     MsgYes => (print "User has FTP permissions.\n";

864 OS.Process.success)

                   | MsgNo => (print "User does not have FTP permissions.\n";

866 OS.Process.failure)

                   | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");

868 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

870 OS.Process.failure)

871 in

872 loop ()

873 before OpenSSL.close bio

874 end

875

876 fun requestTrustedPath {node, uname} =

877 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then

880 dispatcher

881 else

                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

883

         val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))

885

886 fun loop () =

887 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

889 OS.Process.failure)

890 | SOME m =>

891 case m of

                     MsgYes => (print "User has trusted path restriction.\n";

893 OS.Process.success)

                   | MsgNo => (print "User does not have trusted path restriction.\n";

895 OS.Process.failure)

                   | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");

897 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

899 OS.Process.failure)

900 in

901 loop ()

902 before OpenSSL.close bio

903 end

904

905 fun requestSocketPerm {node, uname} =

906 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then

909 dispatcher

910 else

                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

912

         val _ = Msg.send (bio, MsgQuery (QSocket uname))

914

915 fun loop () =

916 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

918 OS.Process.failure)

919 | SOME m =>

920 case m of

921 MsgSocket p => (case p of

922 Any => print "Any\n"

923 | Client => print "Client\n"

924 | Server => print "Server\n"

                                       | Nada => print "Nada\n";

926 OS.Process.success)

                   | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");

928 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

930 OS.Process.failure)

931 in

932 loop ()

933 before OpenSSL.close bio

934 end

935

936 fun requestFirewall {node, uname} =

937 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then

940 dispatcher

941 else

                                                      Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

943

         val _ = Msg.send (bio, MsgQuery (QFirewall {node = node, user = uname}))

945

946 fun loop () =

947 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

949 OS.Process.failure)

950 | SOME m =>

951 case m of

                     MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;

953 OS.Process.success)

                   | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");

955 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

957 OS.Process.failure)

958 in

959 loop ()

960 before OpenSSL.close bio

961 end

962

963 fun requestDescribe dom =

964 let

         val (_, bio) = requestBio (fn () => ())

966 in

         Msg.send (bio, MsgDescribe dom);

968 case Msg.recv bio of

969 NONE => print "Server closed connection unexpectedly.\n"

970 | SOME m =>

971 case m of

972 MsgDescription s => print s

               | MsgError s => print ("Description failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

975 OpenSSL.close bio

976 end

977

978 fun requestReUsers () =

979 let

         val (_, bio) = requestBio (fn () => ())

981 in

         Msg.send (bio, MsgReUsers);

983 case Msg.recv bio of

984 NONE => print "Server closed connection unexpectedly.\n"

985 | SOME m =>

986 case m of

987 MsgOk => print "Callbacks run.\n"

               | MsgError s => print ("Failed: " ^ s ^ "\n")

               | _ => print "Unexpected server reply.\n";

990 OpenSSL.close bio

991 end

992

993 fun requestFirewallRegen node =

994 let

         val (user, context) = requestContext (fn () => ())

         val bio = OpenSSL.connect true (context, Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)

997 (* Only supporting on slave nodes *)

998

         val _ = Msg.send (bio, MsgFirewallRegen)

1000

1001 fun handleResult () =

1002 case Msg.recv bio of

                 NONE => (print "Server closed connection unexpectedly.\n";

1004 OS.Process.failure)

1005 | SOME m =>

1006 case m of

                     MsgOk => (print "Firewall regenerated.\n";

1008 OS.Process.success)

                   | MsgError s => (print ("Firewall regeneration failed: " ^ s ^ "\n");

1010 OS.Process.failure)

                   | _ => (print "Unexpected server reply.\n";

1012 OS.Process.failure)

1013 in

1014 handleResult()

1015 before OpenSSL.close bio

1016 end

1017

1018 structure SS = StringSet

1019

1020 fun domainList dname =

1021 let

1022 val dir = Posix.FileSys.opendir dname

1023

1024 fun visitNode dset =

1025 case Posix.FileSys.readdir dir of

1026 NONE => dset

1027 | SOME node =>

1028 let

                     val path = OS.Path.joinDirFile {dir = dname,

1030 file = node}

1031

                     fun visitDomains (path, bfor, dset) =

1033 let

1034 val dir = Posix.FileSys.opendir path

1035

1036 fun loop dset =

1037 case Posix.FileSys.readdir dir of

1038 NONE => dset

1039 | SOME dname =>

1040 let

                                         val path = OS.Path.joinDirFile {dir = path,

1042 file = dname}

1043 in

                                         if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then

1045 let

1046 val bfor = dname :: bfor

1047 in

                                                 loop (visitDomains (path, bfor,

1049 SS.add (dset,

1050 String.concatWith "." bfor)))

1051 end

1052 else

1053 loop dset

1054 end

1055 in

1056 loop dset

1057 before Posix.FileSys.closedir dir

1058 end

1059 in

                     visitNode (visitDomains (path, [], dset))

1061 end

1062 in

1063 visitNode SS.empty

1064 before Posix.FileSys.closedir dir

1065 end

1066

1067 fun regenerateEither tc checker context =

1068 let

         val () = print "Starting regeneration....\n"

1070

1071 val domainsBefore =

1072 if tc then

1073 SS.empty

1074 else

1075 domainList Config.resultRoot

1076

1077 fun ifReal f =

1078 if tc then

1079 ()

1080 else

1081 f ()

1082

         val _ = ErrorMsg.reset ()

1084

1085 val b = basis ()

         val () = Tycheck.disallowExterns ()

1087

         val () = ifReal (fn () =>

                             (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));

                              ignore (OS.Process.system ("cp -r " ^ Config.resultRoot

1091 ^ "/* " ^ Config.oldResultRoot ^ "/"));

1092 Domain.resetGlobal ()))

1093

1094 val ok = ref true

1095

         fun contactNode (node, ip, ipv6) =

1097 if node = Config.dispatcherName then

1098 Domain.resetLocal ()

1099 else let

                     val bio = OpenSSL.connect true (context,

1101 ip

1102 ^ ":"

1103 ^ Int.toString Config.slavePort)

1104 in

                     Msg.send (bio, MsgRegenerate);

1106 case Msg.recv bio of

1107 NONE => print "Slave closed connection unexpectedly\n"

1108 | SOME m =>

1109 case m of

                             MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")

1111 | MsgError s => print ("Slave " ^ node

1112 ^ " returned error: " ^

1113 s ^ "\n")

1114 | _ => print ("Slave " ^ node

1115 ^ " returned unexpected command\n");

1116 OpenSSL.close bio

1117 end

                  handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")

1119

1120 fun doUser user =

1121 let

1122 val _ = Domain.setUser user

                 val _ = ErrorMsg.reset ()

1124

1125 val dname = Config.domtoolDir user

1126 in

                 if Posix.FileSys.access (dname, []) then

1128 let

1129 val dir = Posix.FileSys.opendir dname

1130

1131 fun loop files =

1132 case Posix.FileSys.readdir dir of

1133 NONE => (Posix.FileSys.closedir dir;

1134 files)

1135 | SOME fname =>

1136 if notTmp fname then

                                     loop (OS.Path.joinDirFile {dir = dname,

1138 file = fname}

1139 :: files)

1140 else

1141 loop files

1142

1143 val files = loop []

                         val (_, files) = Order.order (SOME b) files

1145

                         fun checker' (file, (G, evs)) =

1147 checker G evs file

1148 in

1149 if !ErrorMsg.anyErrors then

1150 (ErrorMsg.reset ();

                              print ("User " ^ user ^ "'s configuration has errors!\n");

1152 ok := false)

1153 else

1154 ();

                         let val basis' = basis () in

                             ignore (foldl checker' (basis', SM.empty) files)

1157 end

1158 end

                 else if (String.isSuffix "_admin" user) orelse (String.isSuffix ".daemon" user) then

1160 ()

1161 else

                     (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");

1163 ok := false)

1164 end

             handle IO.Io {name, function, ...} =>

                    (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");

1167 ok := false)

                  | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");

1169 ok := false)

                  | ErrorMsg.Error => (ErrorMsg.reset ();

                                       print ("User " ^ user ^ " had a compilation error.\n");

1172 ok := false)

                  | _ => (print "Unknown exception during regeneration!\n";

1174 ok := false)

1175 in

         ifReal (fn () => (app contactNode Config.nodeIps;

1177 Env.pre ()));

         app doUser (Acl.users ());

1179 ifReal (fn () =>

1180 let

1181 val domainsAfter = domainList Config.resultRoot

                        val domainsGone = SS.difference (domainsBefore, domainsAfter)

1183 in

1184 if SS.isEmpty domainsGone then

1185 ()

1186 else

1187 (print "Domains to kill:";

                             SS.app (fn s => (print " "; print s)) domainsGone;

1189 print "\n";

1190

                             Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));

1192

1193 Env.post ()

1194 end);

1195 !ok

1196 end

1197

1198 val regenerate = regenerateEither false eval

1199 val regenerateTc = regenerateEither true

                                     (fn G => fn evs => fn file =>

                                                           (#1 (check G file), evs))

1202

1203 fun usersChanged () =

1204 (Domain.onUsersChange ();

      ignore (OS.Process.system Config.publish_reusers))

1206

1207 fun rmuser user =

1208 let

         val doms = Acl.class {user = user, class = "domain"}

         val doms = List.filter (fn dom =>

                                    case Acl.whoHas {class = "domain", value = dom} of

1212 [_] => true

                                      | _ => false) (StringSet.listItems doms)

1214 in

1215 Acl.rmuser user;

1216 Domain.rmdom doms;

1217 usersChanged ()

1218 end

1219

 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))

1221

1222 fun answerQuery q =

1223 case q of

         QApt pkg => if Apt.installed pkg then MsgYes else MsgNo

1225 | QAptExists pkg => (case Apt.info pkg of

                               SOME {section, description} => MsgAptQuery {section = section, description = description}

1227 | NONE => MsgNo)

       | QCron user => if Cron.allowed user then MsgYes else MsgNo

       | QFtp user => if Ftp.allowed user then MsgYes else MsgNo

       | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo

       | QSocket user => MsgSocket (SocketPerm.query user)

       | QFirewall {node, user} => MsgFirewall (Firewall.query (node, user))

1233

1234 fun describeQuery q =

1235 case q of

1236 QApt pkg => "Requested installation status of package " ^ pkg

1237 | QAptExists pkg => "Requested if package " ^ pkg ^ " exists"

1238 | QCron user => "Asked about cron permissions for user " ^ user

1239 | QFtp user => "Asked about FTP permissions for user " ^ user

1240 | QTrustedPath user => "Asked about trusted path settings for user " ^ user

1241 | QSocket user => "Asked about socket permissions for user " ^ user

       | QFirewall {node, user} => "Asked about firewall rules on " ^ node ^ " for user " ^ user

1243

1244 fun doIt' loop bio f cleanup =

                ((case f () of

1246 (msgLocal, SOME msgRemote) =>

1247 (print msgLocal;

1248 print "\n";

                       Msg.send (bio, MsgError msgRemote))

1250 | (msgLocal, NONE) =>

1251 (print msgLocal;

1252 print "\n";

                       Msg.send (bio, MsgOk)))

                 handle e as (OpenSSL.OpenSSL s) =>

                        (print ("OpenSSL error: " ^ s ^ "\n");

                         app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);

                         Msg.send (bio, MsgError ("OpenSSL error: " ^ s))

1258 handle OpenSSL.OpenSSL _ => ())

                      | OS.SysErr (s, _) =>

1260 (print "System error: ";

1261 print s;

1262 print "\n";

                         Msg.send (bio, MsgError ("System error: " ^ s))

1264 handle OpenSSL.OpenSSL _ => ())

1265 | Fail s =>

1266 (print "Failure: ";

1267 print s;

1268 print "\n";

                         Msg.send (bio, MsgError ("Failure: " ^ s))

1270 handle OpenSSL.OpenSSL _ => ())

1271 | ErrorMsg.Error =>

                        (print "Compilation error\n";

                         Msg.send (bio, MsgError "Error during configuration evaluation")

1274 handle OpenSSL.OpenSSL _ => ());

1275 (cleanup ();

1276 ignore (OpenSSL.readChar bio);

1277 OpenSSL.close bio)

1278 handle OpenSSL.OpenSSL _ => ();

1279 loop ())

1280

1281 fun service () =

1282 let

         val host = Slave.hostname ()

1284

1285 val () = Acl.read Config.aclFile

1286

         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",

1288 Config.keyDir ^ "/" ^ host ^ "/key.pem",

1289 Config.trustStore)

1290 val _ = Domain.set_context context

1291

         val sock = OpenSSL.listen (context, Config.dispatcherPort)

1293

1294 fun loop () =

1295 (case OpenSSL.accept sock of

1296 NONE => ()

1297 | SOME bio =>

1298 let

1299 val user = OpenSSL.peerCN bio

                      val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")

1301 val () = Domain.setUser user

1302 val doIt = doIt' loop bio

1303

1304 fun doConfig codes =

1305 let

                              val _ = print "Configuration:\n"

                              val _ = app (fn s => (print s; print "\n")) codes

                              val _ = print "\n"

1309

                              val outname = OS.FileSys.tmpName ()

1311

                              fun doOne (code, (G, evs)) =

1313 let

1314 val outf = TextIO.openOut outname

1315 in

                                      TextIO.output (outf, code);

1317 TextIO.closeOut outf;

1318 eval G evs outname

1319 end

1320 in

                              doIt (fn () => (Env.pre ();

                                              let val basis' = basis () in

                                                  ignore (foldl doOne (basis', SM.empty) codes)

1324 end;

1325 Env.post ();

                                              Msg.send (bio, MsgOk);

1327 ("Configuration complete.", NONE)))

                                   (fn () => OS.FileSys.remove outname)

1329 end

1330

1331 fun checkAddr s =

                          case String.fields (fn ch => ch = #"@") s of

1333 [user'] =>

1334 if user = user' then

1335 SOME (SetSA.User s)

1336 else

1337 NONE

1338 | [user', domain] =>

                              if Domain.validEmailUser user' andalso Domain.yourDomain domain then

1340 SOME (SetSA.Email s)

1341 else

1342 NONE

1343 | _ => NONE

1344

1345 fun cmdLoop () =

1346 case Msg.recv bio of

1347 NONE => (OpenSSL.close bio

1348 handle OpenSSL.OpenSSL _ => ();

1349 loop ())

1350 | SOME m =>

1351 case m of

1352 MsgConfig code => doConfig [code]

1353 | MsgMultiConfig codes => doConfig codes

1354

1355 | MsgShutdown =>

                                  if Acl.query {user = user, class = "priv", value = "all"}

                                     orelse Acl.query {user = user, class = "priv", value = "shutdown"} then

                                      print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")

1359 else

                                      (print "Unauthorized shutdown command!\n";

1361 OpenSSL.close bio

1362 handle OpenSSL.OpenSSL _ => ();

1363 loop ())

1364

1365 | MsgGrant acl =>

1366 doIt (fn () =>

                                           if Acl.query {user = user, class = "priv", value = "all"} then

1368 (Acl.grant acl;

1369 Acl.write Config.aclFile;

1370 if #class acl = "user" then

1371 usersChanged ()

1372 else

1373 ();

                                                ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",

1375 NONE))

1376 else

1377 ("Unauthorized user asked to grant a permission!",

1378 SOME "Not authorized to grant privileges"))

1379 (fn () => ())

1380

1381 | MsgRevoke acl =>

1382 doIt (fn () =>

                                           if Acl.query {user = user, class = "priv", value = "all"} then

1384 (Acl.revoke acl;

1385 Acl.write Config.aclFile;

                                                ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",

1387 NONE))

1388 else

1389 ("Unauthorized user asked to revoke a permission!",

1390 SOME "Not authorized to revoke privileges"))

1391 (fn () => ())

1392

1393 | MsgListPerms user =>

1394 doIt (fn () =>

                                           (Msg.send (bio, MsgPerms (Acl.queryAll user));

1396 ("Sent permission list for user " ^ user ^ ".",

1397 NONE)))

1398 (fn () => ())

1399

1400 | MsgWhoHas perm =>

1401 doIt (fn () =>

                                           (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));

                                            ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",

1404 NONE)))

1405 (fn () => ())

1406

1407 | MsgRmdom doms =>

1408 doIt (fn () =>

                                           if Acl.query {user = user, class = "priv", value = "all"}

                                              orelse List.all (fn dom => Domain.validDomain dom

                                                                         andalso Acl.queryDomain {user = user, domain = dom}) doms then

1412 (Domain.rmdom doms;

                                                (*app (fn dom =>

                                                        Acl.revokeFromAll {class = "domain", value = dom}) doms;

1415 Acl.write Config.aclFile;*)

                                                ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",

1417 NONE))

1418 else

1419 ("Unauthorized user asked to remove a domain!",

1420 SOME "Not authorized to remove that domain"))

1421 (fn () => ())

1422

1423 | MsgRegenerate =>

1424 doIt (fn () =>

                                           if Acl.query {user = user, class = "priv", value = "regen"}

                                              orelse Acl.query {user = user, class = "priv", value = "all"} then

1427 (if regenerate context then

1428 ("Regenerated all configuration.",

1429 NONE)

1430 else

1431 ("Error regenerating configuration!",

1432 SOME "Error regenerating configuration! Consult /var/log/domtool.log."))

1433 else

1434 ("Unauthorized user asked to regenerate!",

1435 SOME "Not authorized to regenerate"))

1436 (fn () => ())

1437

1438 | MsgRegenerateTc =>

1439 doIt (fn () =>

                                           if Acl.query {user = user, class = "priv", value = "regen"}

                                              orelse Acl.query {user = user, class = "priv", value = "all"} then

1442 (if regenerateTc context then

1443 ("Checked all configuration.",

1444 NONE)

1445 else

1446 ("Found a compilation error!",

1447 SOME "Found a compilation error! Consult /var/log/domtool.log."))

1448 else

1449 ("Unauthorized user asked to regenerate -tc!",

1450 SOME "Not authorized to regenerate -tc"))

1451 (fn () => ())

1452

1453 | MsgRmuser user' =>

1454 doIt (fn () =>

                                           if Acl.query {user = user, class = "priv", value = "all"} then

1456 (rmuser user';

1457 Acl.write Config.aclFile;

                                                ("Removed user " ^ user' ^ ".",

1459 NONE))

1460 else

1461 ("Unauthorized user asked to remove a user!",

1462 SOME "Not authorized to remove users"))

1463 (fn () => ())

1464

1465 | MsgListMailboxes domain =>

1466 doIt (fn () =>

                                           if not (Domain.yourDomain domain) then

1468 ("User wasn't authorized to list mailboxes for " ^ domain,

1469 SOME "You're not authorized to configure that domain.")

1470 else

1471 case Vmail.list domain of

                                                   Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);

1473 ("Sent mailbox list for " ^ domain,

1474 NONE))

                                                 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,

1476 SOME msg))

1477 (fn () => ())

1478

                                | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>

1480 doIt (fn () =>

                                           if not (Domain.yourDomain domain) then

1482 ("User wasn't authorized to add a mailbox to " ^ domain,

1483 SOME "You're not authorized to configure that domain.")

                                           else if not (Domain.validEmailUser emailUser) then

1485 ("Invalid e-mail username " ^ emailUser,

1486 SOME "Invalid e-mail username")

                                           else if not (CharVector.all Char.isGraph passwd) then

1488 ("Invalid password",

1489 SOME "Invalid password; may only contain printable, non-space characters")

                                           else if not (Domain.yourPath mailbox) then

1491 ("User wasn't authorized to add a mailbox at " ^ mailbox,

1492 SOME ("You're not authorized to use that mailbox location. ("

1493 ^ mailbox ^ ")"))

1494 else

                                               case Vmail.add {requester = user,

1496 domain = domain, user = emailUser,

                                                               passwd = passwd, mailbox = mailbox} of

                                                   NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,

1499 NONE)

                                                 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,

1501 SOME msg))

1502 (fn () => ())

1503

                                | MsgPasswdMailbox {domain, user = emailUser, passwd} =>

1505 doIt (fn () =>

                                           if not (Domain.yourDomain domain) then

1507 ("User wasn't authorized to change password of a mailbox for " ^ domain,

1508 SOME "You're not authorized to configure that domain.")

                                           else if not (Domain.validEmailUser emailUser) then

1510 ("Invalid e-mail username " ^ emailUser,

1511 SOME "Invalid e-mail username")

                                           else if not (CharVector.all Char.isGraph passwd) then

1513 ("Invalid password",

1514 SOME "Invalid password; may only contain printable, non-space characters")

1515 else

                                               case Vmail.passwd {domain = domain, user = emailUser,

1517 passwd = passwd} of

1518 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,

1519 NONE)

                                                 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,

1521 SOME msg))

1522 (fn () => ())

1523

                                | MsgPortalPasswdMailbox {domain, user = emailUser, oldpasswd, newpasswd} =>

1525 doIt (fn () =>

                                           if not (Acl.query {user = user, class = "priv", value = "vmail"}) then

1527 ("User is not authorized to run portal vmail password",

1528 SOME "You're not authorized to use the portal password command")

                                           else if not (Domain.validEmailUser emailUser) then

1530 ("Invalid e-mail username " ^ emailUser,

1531 SOME "Invalid e-mail username")

                                           else if not (CharVector.all Char.isGraph oldpasswd

                                                       andalso CharVector.all Char.isGraph newpasswd) then

1534 ("Invalid password",

1535 SOME "Invalid password; may only contain printable, non-space characters")

1536 else

                                               case Vmail.portalpasswd {domain = domain, user = emailUser,

                                                                        oldpasswd = oldpasswd, newpasswd = newpasswd} of

1539 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,

1540 NONE)

                                                 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,

1542 SOME msg))

1543 (fn () => ())

1544

1545 | MsgRmMailbox {domain, user = emailUser} =>

1546 doIt (fn () =>

                                           if not (Domain.yourDomain domain) then

1548 ("User wasn't authorized to change password of a mailbox for " ^ domain,

1549 SOME "You're not authorized to configure that domain.")

                                           else if not (Domain.validEmailUser emailUser) then

1551 ("Invalid e-mail username " ^ emailUser,

1552 SOME "Invalid e-mail username")

1553 else

                                               case Vmail.rm {domain = domain, user = emailUser} of

1555 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,

1556 NONE)

                                                 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,

1558 SOME msg))

1559 (fn () => ())

1560

1561 | MsgSaQuery addr =>

1562 doIt (fn () =>

1563 case checkAddr addr of

1564 NONE => ("User tried to query SA filtering for " ^ addr,

1565 SOME "You aren't allowed to configure SA filtering for that recipient.")

                                             | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));

1567 ("Queried SA filtering status for " ^ addr,

1568 NONE)))

1569 (fn () => ())

1570

1571 | MsgSaSet (addr, b) =>

1572 doIt (fn () =>

1573 case checkAddr addr of

1574 NONE => ("User tried to set SA filtering for " ^ addr,

1575 SOME "You aren't allowed to configure SA filtering for that recipient.")

                                             | SOME addr' => (SetSA.set (addr', b);

1577 SetSA.rebuild ();

                                                              Msg.send (bio, MsgOk);

1579 ("Set SA filtering status for " ^ addr ^ " to "

                                                               ^ (if b then "ON" else "OFF"),

1581 NONE)))

1582 (fn () => ())

1583

1584 | MsgSmtpLogReq domain =>

1585 doIt (fn () =>

                                           if not (Domain.yourDomain domain) then

1587 ("Unauthorized user tried to request SMTP logs for " ^ domain,

1588 SOME "You aren't authorized to configure that domain.")

1589 else

                                               (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))

1591 domain;

1592 ("Requested SMTP logs for " ^ domain,

1593 NONE)))

1594 (fn () => ())

1595

1596 | MsgQuery q =>

                                  doIt (fn () => (Msg.send (bio, answerQuery q);

1598 (describeQuery q,

1599 NONE)))

1600 (fn () => ())

1601 | MsgDescribe dom =>

                                  doIt (fn () => if not (Domain.validDomain dom) then

1603 ("Requested description of invalid domain " ^ dom,

1604 SOME "Invalid domain name")

1605 else if not (Domain.yourDomain dom

                                                              orelse Acl.query {user = user, class = "priv", value = "all"}) then

1607 ("Requested description of " ^ dom ^ ", but not allowed access",

1608 SOME "Access denied")

1609 else

                                                     (Msg.send (bio, MsgDescription (Domain.describe dom));

1611 ("Sent description of domain " ^ dom,

1612 NONE)))

1613 (fn () => ())

1614

1615 | MsgReUsers =>

                                  doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}

                                                    orelse Acl.query {user = user, class = "priv", value = "all"} then

1618 (usersChanged ();

1619 ("Users change callbacks run", NONE))

1620 else

1621 ("Unauthorized user asked to reusers!",

1622 SOME "You aren't authorized to regenerate files."))

1623 (fn () => ())

1624

1625 | _ =>

                                  doIt (fn () => ("Unexpected command",

1627 SOME "Unexpected command"))

1628 (fn () => ())

1629 in

1630 cmdLoop ()

1631 end

                  handle e as (OpenSSL.OpenSSL s) =>

                         (print ("OpenSSL error: " ^ s ^ "\n");

                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);

1635 OpenSSL.close bio

1636 handle OpenSSL.OpenSSL _ => ();

1637 loop ())

                       | OS.SysErr (s, _) =>

                         (print ("System error: " ^ s ^ "\n");

1640 OpenSSL.close bio

1641 handle OpenSSL.OpenSSL _ => ();

1642 loop ())

                       | IO.Io {name, function, cause} =>

                         (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");

                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);

1646 OpenSSL.close bio

1647 handle OpenSSL.OpenSSL _ => ();

1648 loop ())

1649 | OS.Path.InvalidArc =>

                         (print "Invalid arc\n";

1651 OpenSSL.close bio

1652 handle OpenSSL.OpenSSL _ => ();

1653 loop ())

1654 | e =>

                         (print "Unknown exception in main loop!\n";

                          app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);

1657 OpenSSL.close bio

1658 handle OpenSSL.OpenSSL _ => ();

1659 loop ()))

             handle e as (OpenSSL.OpenSSL s) =>

                    (print ("OpenSSL error: " ^ s ^ "\n");

                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);

1663 loop ())

                  | OS.SysErr (s, _) =>

                    (print ("System error: " ^ s ^ "\n");

1666 loop ())

                  | IO.Io {name, function, cause} =>

                    (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");

                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);

1670 loop ())

1671 | e =>

                    (print "Unknown exception in main loop!\n";

                     app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);

1674 loop ())

1675 in

         print ("Domtool dispatcher starting up at " ^ now () ^ "\n");

1677 print "Listening for connections....\n";

1678 loop ();

1679 OpenSSL.shutdown sock

1680 end

1681

1682 fun slave () =

1683 let

         val host = Slave.hostname ()

1685

         val context = context (Config.certDir ^ "/" ^ host ^ ".pem",

1687 Config.keyDir ^ "/" ^ host ^ "/key.pem",

1688 Config.trustStore)

1689

         val sock = OpenSSL.listen (context, Config.slavePort)

1691

         val _ = print ("Slave server starting at " ^ now () ^ "\n")

1693

1694 fun loop () =

1695 (case OpenSSL.accept sock of

1696 NONE => ()

1697 | SOME bio =>

1698 let

1699 val peer = OpenSSL.peerCN bio

                      val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")

1701 in

1702 if peer = Config.dispatcherName then let

1703 fun loop' files =

1704 case Msg.recv bio of

1705 NONE => print "Dispatcher closed connection unexpectedly\n"

1706 | SOME m =>

1707 case m of

1708 MsgFile file => loop' (file :: files)

1709 | MsgDoFiles => (Slave.handleChanges files;

                                                         Msg.send (bio, MsgOk))

1711 | MsgRegenerate => (Domain.resetLocal ();

                                                            Msg.send (bio, MsgOk))

                                        | MsgVmailChanged => (if Vmail.doChanged () then

                                                                  Msg.send (bio, MsgOk)

1715 else

                                                                  Msg.send (bio, MsgError "userdb update failed"))

                                        | MsgSaChanged => (if Slave.shell [Config.SpamAssassin.postReload] then

                                                               Msg.send (bio, MsgOk)

1719 else

                                                               Msg.send (bio, MsgError "Error reloading SpamAssassin addresses"))

                                        | _ => (print "Dispatcher sent unexpected command\n";

                                                Msg.send (bio, MsgError "Unexpected command"))

1723 in

1724 loop' [];

1725 ignore (OpenSSL.readChar bio);

1726 OpenSSL.close bio;

1727 loop ()

1728 end

1729 else if peer = "domtool" then

1730 case Msg.recv bio of

1731 SOME MsgShutdown => (OpenSSL.close bio;

                                                   print ("Shutting down at " ^ now () ^ "\n\n"))

1733 | _ => (OpenSSL.close bio;

1734 loop ())

1735 else

1736 let

1737 val doIt = doIt' loop bio

1738 val user = peer

1739 in

1740 case Msg.recv bio of

1741 NONE => (OpenSSL.close bio

1742 handle OpenSSL.OpenSSL _ => ();

1743 loop ())

1744 | SOME m =>

1745 case m of

                                      (MsgQuery q) => (print (describeQuery q ^ "\n");

                                                       Msg.send (bio, answerQuery q);

1748 ignore (OpenSSL.readChar bio);

1749 OpenSSL.close bio;

1750 loop ())

1751 | MsgCreateDbUser {dbtype, passwd} =>

1752 doIt (fn () =>

1753 case Dbms.lookup dbtype of

1754 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,

1755 SOME ("Unknown database type " ^ dbtype))

1756 | SOME handler =>

                                                   case #adduser handler {user = user, passwd = passwd} of

                                                       NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",

1759 NONE)

1760 | SOME msg =>

                                                       ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,

1762 SOME ("Error adding user: " ^ msg)))

1763 (fn () => ())

1764

1765 | MsgDbPasswd {dbtype, passwd} =>

1766 doIt (fn () =>

1767 case Dbms.lookup dbtype of

1768 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,

1769 SOME ("Unknown database type " ^ dbtype))

1770 | SOME handler =>

                                                   case #passwd handler {user = user, passwd = passwd} of

                                                       NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",

1773 NONE)

1774 | SOME msg =>

                                                       ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,

1776 SOME ("Error adding user: " ^ msg)))

1777 (fn () => ())

1778

1779 | MsgCreateDb {dbtype, dbname, encoding} =>

1780 doIt (fn () =>

1781 if Dbms.validDbname dbname then

1782 case Dbms.lookup dbtype of

1783 NONE => ("Database creation request with unknown datatype type " ^ dbtype,

1784 SOME ("Unknown database type " ^ dbtype))

1785 | SOME handler =>

                                                       if not (Dbms.validEncoding encoding) then

1787 ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",

1788 SOME "Invalid encoding")

1789 else

                                                           case #createdb handler {user = user, dbname = dbname, encoding = encoding} of

                                                               NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",

1792 NONE)

                                                             | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,

1794 SOME ("Error creating database: " ^ msg))

1795 else

1796 ("Invalid database name " ^ user ^ "_" ^ dbname,

1797 SOME ("Invalid database name " ^ dbname)))

1798 (fn () => ())

1799

1800 | MsgDropDb {dbtype, dbname} =>

1801 doIt (fn () =>

1802 if Dbms.validDbname dbname then

1803 case Dbms.lookup dbtype of

1804 NONE => ("Database drop request with unknown datatype type " ^ dbtype,

1805 SOME ("Unknown database type " ^ dbtype))

1806 | SOME handler =>

                                                       case #dropdb handler {user = user, dbname = dbname} of

                                                           NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",

1809 NONE)

                                                         | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,

1811 SOME ("Error dropping database: " ^ msg))

1812 else

1813 ("Invalid database name " ^ user ^ "_" ^ dbname,

1814 SOME ("Invalid database name " ^ dbname)))

1815 (fn () => ())

1816

1817 | MsgGrantDb {dbtype, dbname} =>

1818 doIt (fn () =>

1819 if Dbms.validDbname dbname then

1820 case Dbms.lookup dbtype of

1821 NONE => ("Database drop request with unknown datatype type " ^ dbtype,

1822 SOME ("Unknown database type " ^ dbtype))

1823 | SOME handler =>

                                                       case #grant handler {user = user, dbname = dbname} of

                                                           NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",

1826 NONE)

                                                         | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,

1828 SOME ("Error granting permissions to database: " ^ msg))

1829 else

1830 ("Invalid database name " ^ user ^ "_" ^ dbname,

1831 SOME ("Invalid database name " ^ dbname)))

1832 (fn () => ())

1833 | MsgFirewallRegen =>

                                      doIt (fn () => (Acl.read Config.aclFile;

                                                      if Acl.query {user = user, class = "priv", value = "all"} then

                                                          if List.exists (fn x => x = host) Config.Firewall.firewallNodes then

                                                              if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())

1838 then

1839 ("Firewall rules regenerated.", NONE)

1840 else

                                                                 ("Rules regeneration failed!", SOME "Script execution failed.")

                                                         else ("Node not controlled by domtool firewall.", SOME (host))

1843 else

                                                          ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))

1845 (fn () => ())

1846

1847 | _ => (OpenSSL.close bio;

1848 loop ())

1849 end

1850 end handle OpenSSL.OpenSSL s =>

                             (print ("OpenSSL error: " ^ s ^ "\n");

1852 OpenSSL.close bio

1853 handle OpenSSL.OpenSSL _ => ();

1854 loop ())

                           | e as OS.SysErr (s, _) =>

                             (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);

                              print ("System error: "^ s ^ "\n");

1858 OpenSSL.close bio

1859 handle OpenSSL.OpenSSL _ => ();

1860 loop ())

1861 | IO.Io {function, name, ...} =>

                             (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");

1863 OpenSSL.close bio

1864 handle OpenSSL.OpenSSL _ => ();

1865 loop ())

1866 | e =>

                             (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);

1868 print "Uncaught exception!\n";

1869 OpenSSL.close bio

1870 handle OpenSSL.OpenSSL _ => ();

1871 loop ()))

1872 handle OpenSSL.OpenSSL s =>

                    (print ("OpenSSL error: " ^ s ^ "\n");

1874 loop ())

1875 | e =>

                    (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);

1877 print "Uncaught exception!\n";

1878 loop ())

1879 in

1880 loop ();

1881 OpenSSL.shutdown sock

1882 end

1883

1884 fun listBasis () =

1885 let

         val dir = Posix.FileSys.opendir Config.libRoot

1887

1888 fun loop files =

1889 case Posix.FileSys.readdir dir of

1890 NONE => (Posix.FileSys.closedir dir;

1891 files)

1892 | SOME fname =>

1893 if String.isSuffix ".dtl" fname then

                     loop (OS.Path.joinDirFile {dir = Config.libRoot,

1895 file = fname}

1896 :: files)

1897 else

1898 loop files

1899 in

1900 loop []

1901 end

1902

1903 fun autodocBasis outdir =

     Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}

1905

1906 end