Start of DBMS support
[hcoop/domtool2.git] / src / main.sml
CommitLineData
234b917a
AC
1(* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
dac62e84 17 *)
234b917a
AC
18
19(* Main interface *)
20
21structure Main :> MAIN = struct
22
36e42cb8 23open Ast MsgTypes Print
234b917a 24
6ae327f8
AC
25structure SM = StringMap
26
aa56e112 27fun init () = Acl.read Config.aclFile
234b917a 28
d189ec0e 29fun check' G fname =
a3698041
AC
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
d189ec0e 34 G
a3698041 35 else
aa56e112 36 Tycheck.checkFile G (Defaults.tInit ()) prog
a3698041
AC
37 end
38
d189ec0e 39fun basis () =
234b917a 40 let
d189ec0e
AC
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
d612d62c
AC
45 NONE => (Posix.FileSys.closedir dir;
46 files)
d189ec0e
AC
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
d612d62c
AC
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
d189ec0e
AC
51 :: files)
52 else
53 loop files
54
55 val files = loop []
c53e82e4 56 val (_, files) = Order.order NONE files
d189ec0e 57 in
6ae327f8
AC
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
b3159a70
AC
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
d189ec0e
AC
64 end
65
66fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
12adf55a 69 val _ = Env.preTycheck ()
d189ec0e
AC
70
71 val b = basis ()
234b917a
AC
72 in
73 if !ErrorMsg.anyErrors then
36e42cb8 74 raise ErrorMsg.Error
234b917a
AC
75 else
76 let
b3159a70 77 val _ = Tycheck.disallowExterns ()
7f012ffd 78 val _ = ErrorMsg.reset ()
d189ec0e 79 val prog = Parse.parse fname
234b917a 80 in
492c1cff 81 if !ErrorMsg.anyErrors then
36e42cb8 82 raise ErrorMsg.Error
492c1cff 83 else
d189ec0e 84 let
aa56e112 85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
d189ec0e 86 in
36e42cb8
AC
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
d189ec0e 91 end
234b917a
AC
92 end
93 end
94
c53e82e4
AC
95val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97fun checkDir dname =
98 let
99 val b = basis ()
100
101 val dir = Posix.FileSys.opendir dname
102
103 fun loop files =
104 case Posix.FileSys.readdir dir of
105 NONE => (Posix.FileSys.closedir dir;
106 files)
107 | SOME fname =>
108 if notTmp fname then
109 loop (OS.Path.joinDirFile {dir = dname,
110 file = fname}
111 :: files)
112 else
113 loop files
114
115 val files = loop []
116 val (_, files) = Order.order (SOME b) files
117 in
118 if !ErrorMsg.anyErrors then
1824f573 119 raise ErrorMsg.Error
c53e82e4
AC
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
1824f573
AC
122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
c53e82e4
AC
126 end
127
d189ec0e 128fun reduce fname =
a3698041 129 let
d189ec0e 130 val (G, body) = check fname
a3698041
AC
131 in
132 if !ErrorMsg.anyErrors then
d189ec0e 133 NONE
a3698041 134 else
d189ec0e
AC
135 case body of
136 SOME body =>
137 let
138 val body' = Reduce.reduceExp G body
139 in
140 (*printd (PD.hovBox (PD.PPS.Rel 0,
141 [PD.string "Result:",
142 PD.space 1,
143 p_exp body']))*)
144 SOME body'
145 end
146 | _ => NONE
a3698041
AC
147 end
148
d189ec0e
AC
149fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
36e42cb8 153 raise ErrorMsg.Error
d189ec0e 154 else
aa56e112 155 Eval.exec (Defaults.eInit ()) body'
36e42cb8 156 | NONE => raise ErrorMsg.Error
d189ec0e 157
1824f573
AC
158fun eval' fname =
159 case reduce fname of
160 (SOME body') =>
161 if !ErrorMsg.anyErrors then
162 raise ErrorMsg.Error
163 else
164 ignore (Eval.exec' (Defaults.eInit ()) body')
165 | NONE => raise ErrorMsg.Error
166
3b267643
AC
167val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
559e89e9 169
5ee41dd0 170fun requestContext f =
07cc384c 171 let
a56cc2c3
AC
172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
5ee41dd0 174
a56cc2c3
AC
175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
5ee41dd0
AC
177
178 val () = f ()
aa56e112 179
aa56e112 180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
a088cea6 181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
3b267643 182 Config.trustStore)
5ee41dd0
AC
183 in
184 (user, context)
185 end
07cc384c 186
5ee41dd0
AC
187fun requestBio f =
188 let
189 val (user, context) = requestContext f
190 in
191 (user, OpenSSL.connect (context, dispatcher))
192 end
193
194fun request fname =
195 let
196 val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9 197
3b267643
AC
198 val inf = TextIO.openIn fname
199
36e42cb8 200 fun loop lines =
3b267643 201 case TextIO.inputLine inf of
36e42cb8
AC
202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
559e89e9 206 in
3b267643 207 TextIO.closeIn inf;
36e42cb8
AC
208 Msg.send (bio, MsgConfig code);
209 case Msg.recv bio of
210 NONE => print "Server closed connection unexpectedly.\n"
211 | SOME m =>
212 case m of
213 MsgOk => print "Configuration succeeded.\n"
214 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
215 | _ => print "Unexpected server reply.\n";
3b267643 216 OpenSSL.close bio
559e89e9 217 end
aa56e112 218 handle ErrorMsg.Error => ()
559e89e9 219
c53e82e4
AC
220fun requestDir dname =
221 let
1824f573
AC
222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
c53e82e4
AC
225
226 val b = basis ()
227
228 val dir = Posix.FileSys.opendir dname
229
230 fun loop files =
231 case Posix.FileSys.readdir dir of
232 NONE => (Posix.FileSys.closedir dir;
233 files)
234 | SOME fname =>
235 if notTmp fname then
236 loop (OS.Path.joinDirFile {dir = dname,
237 file = fname}
238 :: files)
239 else
240 loop files
241
242 val files = loop []
243 val (_, files) = Order.order (SOME b) files
244
245 val _ = if !ErrorMsg.anyErrors then
246 raise ErrorMsg.Error
247 else
248 ()
249
250 val codes = map (fn fname =>
251 let
252 val inf = TextIO.openIn fname
253
254 fun loop lines =
255 case TextIO.inputLine inf of
256 NONE => String.concat (rev lines)
257 | SOME line => loop (line :: lines)
258 in
259 loop []
260 before TextIO.closeIn inf
261 end) files
262 in
1824f573
AC
263 if !ErrorMsg.anyErrors then
264 ()
265 else
266 (Msg.send (bio, MsgMultiConfig codes);
267 case Msg.recv bio of
268 NONE => print "Server closed connection unexpectedly.\n"
269 | SOME m =>
270 case m of
271 MsgOk => print "Configuration succeeded.\n"
272 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
273 | _ => print "Unexpected server reply.\n";
274 OpenSSL.close bio)
c53e82e4
AC
275 end
276 handle ErrorMsg.Error => ()
277
5ee41dd0
AC
278fun requestGrant acl =
279 let
280 val (user, bio) = requestBio (fn () => ())
281 in
282 Msg.send (bio, MsgGrant acl);
283 case Msg.recv bio of
284 NONE => print "Server closed connection unexpectedly.\n"
285 | SOME m =>
286 case m of
287 MsgOk => print "Grant succeeded.\n"
288 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
289 | _ => print "Unexpected server reply.\n";
290 OpenSSL.close bio
291 end
292
411a85f2
AC
293fun requestRevoke acl =
294 let
295 val (user, bio) = requestBio (fn () => ())
296 in
297 Msg.send (bio, MsgRevoke acl);
298 case Msg.recv bio of
299 NONE => print "Server closed connection unexpectedly.\n"
300 | SOME m =>
301 case m of
302 MsgOk => print "Revoke succeeded.\n"
303 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
304 | _ => print "Unexpected server reply.\n";
305 OpenSSL.close bio
306 end
307
08a04eb4
AC
308fun requestListPerms user =
309 let
310 val (_, bio) = requestBio (fn () => ())
311 in
312 Msg.send (bio, MsgListPerms user);
313 (case Msg.recv bio of
314 NONE => (print "Server closed connection unexpectedly.\n";
315 NONE)
316 | SOME m =>
317 case m of
318 MsgPerms perms => SOME perms
319 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
320 NONE)
321 | _ => (print "Unexpected server reply.\n";
322 NONE))
323 before OpenSSL.close bio
324 end
325
094877b1
AC
326fun requestWhoHas perm =
327 let
328 val (_, bio) = requestBio (fn () => ())
329 in
330 Msg.send (bio, MsgWhoHas perm);
331 (case Msg.recv bio of
332 NONE => (print "Server closed connection unexpectedly.\n";
333 NONE)
334 | SOME m =>
335 case m of
336 MsgWhoHasResponse users => SOME users
337 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
338 NONE)
339 | _ => (print "Unexpected server reply.\n";
340 NONE))
341 before OpenSSL.close bio
342 end
343
1824f573
AC
344fun requestRegen () =
345 let
346 val (_, bio) = requestBio (fn () => ())
347 in
348 Msg.send (bio, MsgRegenerate);
349 case Msg.recv bio of
350 NONE => print "Server closed connection unexpectedly.\n"
351 | SOME m =>
352 case m of
353 MsgOk => print "Regeneration succeeded.\n"
354 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
355 | _ => print "Unexpected server reply.\n";
356 OpenSSL.close bio
357 end
358
c189cbe9
AC
359fun requestRmdom dom =
360 let
361 val (_, bio) = requestBio (fn () => ())
362 in
363 Msg.send (bio, MsgRmdom dom);
364 case Msg.recv bio of
365 NONE => print "Server closed connection unexpectedly.\n"
366 | SOME m =>
367 case m of
368 MsgOk => print "Removal succeeded.\n"
369 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
370 | _ => print "Unexpected server reply.\n";
371 OpenSSL.close bio
372 end
373
e69e60cc
AC
374fun requestRmuser user =
375 let
376 val (_, bio) = requestBio (fn () => ())
377 in
378 Msg.send (bio, MsgRmuser user);
379 case Msg.recv bio of
380 NONE => print "Server closed connection unexpectedly.\n"
381 | SOME m =>
382 case m of
383 MsgOk => print "Removal succeeded.\n"
384 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
385 | _ => print "Unexpected server reply.\n";
386 OpenSSL.close bio
387 end
388
d541c618
AC
389fun requestDbUser dbtype =
390 let
391 val (_, bio) = requestBio (fn () => ())
392 in
393 Msg.send (bio, MsgCreateDbUser dbtype);
394 case Msg.recv bio of
395 NONE => print "Server closed connection unexpectedly.\n"
396 | SOME m =>
397 case m of
398 MsgOk => print "Your user has been created.\n"
399 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
400 | _ => print "Unexpected server reply.\n";
401 OpenSSL.close bio
402 end
403
71420f8b 404fun regenerate context =
1824f573
AC
405 let
406 val b = basis ()
71420f8b
AC
407 val () = Tycheck.disallowExterns ()
408
409 val () = Domain.resetGlobal ()
410
411 fun contactNode (node, ip) =
412 if node = Config.defaultNode then
413 Domain.resetLocal ()
414 else let
415 val bio = OpenSSL.connect (context,
416 ip
417 ^ ":"
418 ^ Int.toString Config.slavePort)
419 in
420 Msg.send (bio, MsgRegenerate);
421 case Msg.recv bio of
422 NONE => print "Slave closed connection unexpectedly\n"
423 | SOME m =>
424 case m of
425 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
426 | MsgError s => print ("Slave " ^ node
427 ^ " returned error: " ^
428 s ^ "\n")
429 | _ => print ("Slave " ^ node
430 ^ " returned unexpected command\n");
431 OpenSSL.close bio
432 end
1824f573
AC
433
434 fun doUser user =
435 let
436 val _ = Domain.setUser user
437 val _ = ErrorMsg.reset ()
438
439 val dname = Config.domtoolDir user
440
441 val dir = Posix.FileSys.opendir dname
442
443 fun loop files =
444 case Posix.FileSys.readdir dir of
445 NONE => (Posix.FileSys.closedir dir;
446 files)
447 | SOME fname =>
448 if notTmp fname then
449 loop (OS.Path.joinDirFile {dir = dname,
450 file = fname}
451 :: files)
452 else
453 loop files
454
455 val files = loop []
456 val (_, files) = Order.order (SOME b) files
457 in
458 if !ErrorMsg.anyErrors then
459 print ("User " ^ user ^ "'s configuration has errors!\n")
460 else
461 app eval' files
462 end
463 handle IO.Io _ => ()
464 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
465 in
71420f8b 466 app contactNode Config.nodeIps;
1824f573
AC
467 Env.pre ();
468 app doUser (Acl.users ());
469 Env.post ()
470 end
471
e69e60cc
AC
472fun rmuser user =
473 let
474 val doms = Acl.class {user = user, class = "domain"}
475 val doms = List.filter (fn dom =>
476 case Acl.whoHas {class = "domain", value = dom} of
477 [_] => true
478 | _ => false) (StringSet.listItems doms)
479 in
480 Acl.rmuser user;
481 Domain.rmdom doms
482 end
483
3b267643 484fun service () =
07cc384c 485 let
aa56e112
AC
486 val () = Acl.read Config.aclFile
487
3b267643
AC
488 val context = OpenSSL.context (Config.serverCert,
489 Config.serverKey,
490 Config.trustStore)
36e42cb8 491 val _ = Domain.set_context context
3b267643 492
60534712 493 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
494
495 fun loop () =
60534712 496 case OpenSSL.accept sock of
3b267643
AC
497 NONE => ()
498 | SOME bio =>
499 let
aa56e112
AC
500 val user = OpenSSL.peerCN bio
501 val () = print ("\nConnection from " ^ user ^ "\n")
502 val () = Domain.setUser user
503
c53e82e4
AC
504 fun doConfig codes =
505 let
506 val _ = print "Configuration:\n"
507 val _ = app (fn s => (print s; print "\n")) codes
508 val _ = print "\n"
509
510 val outname = OS.FileSys.tmpName ()
511
512 fun doOne code =
513 let
514 val outf = TextIO.openOut outname
515 in
516 TextIO.output (outf, code);
517 TextIO.closeOut outf;
1824f573 518 eval' outname
c53e82e4
AC
519 end
520 in
1824f573
AC
521 (Env.pre ();
522 app doOne codes;
523 Env.post ();
c53e82e4
AC
524 Msg.send (bio, MsgOk))
525 handle ErrorMsg.Error =>
526 (print "Compilation error\n";
527 Msg.send (bio,
528 MsgError "Error during configuration evaluation"))
529 | OpenSSL.OpenSSL s =>
530 (print "OpenSSL error\n";
531 Msg.send (bio,
532 MsgError
533 ("Error during configuration evaluation: "
534 ^ s)));
535 OS.FileSys.remove outname;
536 (ignore (OpenSSL.readChar bio);
537 OpenSSL.close bio)
538 handle OpenSSL.OpenSSL _ => ();
539 loop ()
540 end
541
36e42cb8
AC
542 fun cmdLoop () =
543 case Msg.recv bio of
544 NONE => (OpenSSL.close bio
545 handle OpenSSL.OpenSSL _ => ();
546 loop ())
547 | SOME m =>
548 case m of
c53e82e4
AC
549 MsgConfig code => doConfig [code]
550 | MsgMultiConfig codes => doConfig codes
5ee41dd0
AC
551
552 | MsgGrant acl =>
be1bea4c 553 if Acl.query {user = user, class = "priv", value = "all"} then
5ee41dd0
AC
554 ((Acl.grant acl;
555 Acl.write Config.aclFile;
411a85f2
AC
556 Msg.send (bio, MsgOk);
557 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
5ee41dd0
AC
558 handle OpenSSL.OpenSSL s =>
559 (print "OpenSSL error\n";
560 Msg.send (bio,
561 MsgError
562 ("Error during granting: "
563 ^ s)));
564 (ignore (OpenSSL.readChar bio);
565 OpenSSL.close bio)
566 handle OpenSSL.OpenSSL _ => ();
567 loop ())
568 else
569 ((Msg.send (bio, MsgError "Not authorized to grant privileges");
411a85f2
AC
570 print "Unauthorized user asked to grant a permission!\n";
571 ignore (OpenSSL.readChar bio);
572 OpenSSL.close bio)
573 handle OpenSSL.OpenSSL _ => ();
574 loop ())
575
576 | MsgRevoke acl =>
be1bea4c 577 if Acl.query {user = user, class = "priv", value = "all"} then
411a85f2
AC
578 ((Acl.revoke acl;
579 Acl.write Config.aclFile;
580 Msg.send (bio, MsgOk);
581 print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
582 handle OpenSSL.OpenSSL s =>
583 (print "OpenSSL error\n";
584 Msg.send (bio,
585 MsgError
586 ("Error during revocation: "
587 ^ s)));
588 (ignore (OpenSSL.readChar bio);
589 OpenSSL.close bio)
590 handle OpenSSL.OpenSSL _ => ();
591 loop ())
592 else
593 ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
594 print "Unauthorized user asked to revoke a permission!\n";
5ee41dd0
AC
595 ignore (OpenSSL.readChar bio);
596 OpenSSL.close bio)
597 handle OpenSSL.OpenSSL _ => ();
598 loop ())
599
08a04eb4
AC
600 | MsgListPerms user =>
601 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
602 print ("Sent permission list for user " ^ user ^ ".\n"))
603 handle OpenSSL.OpenSSL s =>
604 (print "OpenSSL error\n";
605 Msg.send (bio,
606 MsgError
607 ("Error during permission listing: "
608 ^ s)));
609 (ignore (OpenSSL.readChar bio);
610 OpenSSL.close bio)
611 handle OpenSSL.OpenSSL _ => ();
612 loop ())
613
094877b1
AC
614 | MsgWhoHas perm =>
615 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
616 print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
617 handle OpenSSL.OpenSSL s =>
618 (print "OpenSSL error\n";
619 Msg.send (bio,
620 MsgError
621 ("Error during whohas: "
622 ^ s)));
623 (ignore (OpenSSL.readChar bio);
624 OpenSSL.close bio)
625 handle OpenSSL.OpenSSL _ => ();
626 loop ())
627
e69e60cc 628 | MsgRmdom doms =>
c189cbe9 629 if Acl.query {user = user, class = "priv", value = "all"}
e69e60cc
AC
630 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
631 ((Domain.rmdom doms;
632 app (fn dom =>
633 Acl.revokeFromAll {class = "domain", value = dom}) doms;
634 Acl.write Config.aclFile;
c189cbe9 635 Msg.send (bio, MsgOk);
e69e60cc 636 print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n"))
c189cbe9
AC
637 handle OpenSSL.OpenSSL s =>
638 (print "OpenSSL error\n";
639 Msg.send (bio,
640 MsgError
641 ("Error during revocation: "
642 ^ s)));
643 (ignore (OpenSSL.readChar bio);
644 OpenSSL.close bio)
645 handle OpenSSL.OpenSSL _ => ();
646 loop ())
647 else
648 ((Msg.send (bio, MsgError "Not authorized to remove that domain");
649 print "Unauthorized user asked to remove a domain!\n";
650 ignore (OpenSSL.readChar bio);
651 OpenSSL.close bio)
652 handle OpenSSL.OpenSSL _ => ();
1824f573
AC
653 loop ())
654
655 | MsgRegenerate =>
656 if Acl.query {user = user, class = "priv", value = "regen"}
657 orelse Acl.query {user = user, class = "priv", value = "all"} then
71420f8b 658 ((regenerate context;
1824f573
AC
659 Msg.send (bio, MsgOk);
660 print "Regenerated all configuration.\n")
661 handle OpenSSL.OpenSSL s =>
662 (print "OpenSSL error\n";
663 Msg.send (bio,
664 MsgError
665 ("Error during regeneration: "
666 ^ s)));
667 (ignore (OpenSSL.readChar bio);
668 OpenSSL.close bio)
669 handle OpenSSL.OpenSSL _ => ();
670 loop ())
671 else
672 ((Msg.send (bio, MsgError "Not authorized to regeneration");
673 print "Unauthorized user asked to regenerate!\n";
674 ignore (OpenSSL.readChar bio);
675 OpenSSL.close bio)
676 handle OpenSSL.OpenSSL _ => ();
e69e60cc
AC
677 loop ())
678
05323cbc 679 | MsgRmuser user' =>
e69e60cc 680 if Acl.query {user = user, class = "priv", value = "all"} then
05323cbc 681 ((rmuser user';
e69e60cc
AC
682 Acl.write Config.aclFile;
683 Msg.send (bio, MsgOk);
05323cbc 684 print ("Removed user " ^ user' ^ ".\n"))
e69e60cc
AC
685 handle OpenSSL.OpenSSL s =>
686 (print "OpenSSL error\n";
687 Msg.send (bio,
688 MsgError
689 ("Error during revocation: "
690 ^ s)));
691 (ignore (OpenSSL.readChar bio);
692 OpenSSL.close bio)
693 handle OpenSSL.OpenSSL _ => ();
694 loop ())
695 else
696 ((Msg.send (bio, MsgError "Not authorized to remove users");
697 print "Unauthorized user asked to remove a user!\n";
698 ignore (OpenSSL.readChar bio);
699 OpenSSL.close bio)
700 handle OpenSSL.OpenSSL _ => ();
d541c618
AC
701 loop ())
702
703 | MsgCreateDbUser dbtype =>
704 (case Dbms.lookup dbtype of
705 NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
706 print ("Database user creation request with unknown datatype type " ^ dbtype);
707 ignore (OpenSSL.readChar bio))
708 handle OpenSSL.OpenSSL _ => ();
709 OpenSSL.close bio
710 handle OpenSSL.OpenSSL _ => ();
711 loop ())
712 | SOME handler =>
713 case #adduser handler user of
714 NONE => ((Msg.send (bio, MsgOk);
715 print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n"))
716 handle OpenSSL.OpenSSL s =>
717 (print "OpenSSL error\n";
718 Msg.send (bio,
719 MsgError
720 ("Error during creation: "
721 ^ s)));
722 (ignore (OpenSSL.readChar bio);
723 OpenSSL.close bio)
724 handle OpenSSL.OpenSSL _ => ();
725 loop ())
726 | SOME msg => ((Msg.send (bio, MsgError ("Error adding user: " ^ msg));
727 print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n");
728 ignore (OpenSSL.readChar bio);
729 OpenSSL.close bio)
730 handle OpenSSL.OpenSSL _ => ();
731 loop ()))
c189cbe9 732
36e42cb8
AC
733 | _ =>
734 (Msg.send (bio, MsgError "Unexpected command")
735 handle OpenSSL.OpenSSL _ => ();
736 OpenSSL.close bio
737 handle OpenSSL.OpenSSL _ => ();
738 loop ())
739 in
740 cmdLoop ()
741 end
97665758
AC
742 handle OpenSSL.OpenSSL s =>
743 (print ("OpenSSL error: " ^ s ^ "\n");
744 OpenSSL.close bio
745 handle OpenSSL.OpenSSL _ => ();
746 loop ())
747 | OS.SysErr (s, _) =>
748 (print ("System error: " ^ s ^ "\n");
749 OpenSSL.close bio
750 handle OpenSSL.OpenSSL _ => ();
751 loop ())
36e42cb8 752 in
361a1e7f 753 print "Listening for connections....\n";
36e42cb8
AC
754 loop ();
755 OpenSSL.shutdown sock
756 end
757
758fun slave () =
759 let
6e62228d 760 val host = Slave.hostname ()
36e42cb8
AC
761
762 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6 763 Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8
AC
764 Config.trustStore)
765
766 val sock = OpenSSL.listen (context, Config.slavePort)
767
768 fun loop () =
769 case OpenSSL.accept sock of
770 NONE => ()
771 | SOME bio =>
772 let
773 val peer = OpenSSL.peerCN bio
774 val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643 775 in
36e42cb8
AC
776 if peer <> Config.dispatcherName then
777 (print "Not authorized!\n";
778 OpenSSL.close bio;
779 loop ())
780 else let
781 fun loop' files =
782 case Msg.recv bio of
783 NONE => print "Dispatcher closed connection unexpectedly\n"
784 | SOME m =>
785 case m of
786 MsgFile file => loop' (file :: files)
787 | MsgDoFiles => (Slave.handleChanges files;
788 Msg.send (bio, MsgOk))
71420f8b
AC
789 | MsgRegenerate => (Domain.resetLocal ();
790 Msg.send (bio, MsgOk))
36e42cb8
AC
791 | _ => (print "Dispatcher sent unexpected command\n";
792 Msg.send (bio, MsgError "Unexpected command"))
793 in
794 loop' [];
795 ignore (OpenSSL.readChar bio);
796 OpenSSL.close bio;
797 loop ()
798 end
3196000d
AC
799 end handle OpenSSL.OpenSSL s =>
800 (print ("OpenSSL error: "^ s ^ "\n");
801 OpenSSL.close bio
802 handle OpenSSL.OpenSSL _ => ();
803 loop ())
7af7d4cb
AC
804 | OS.SysErr (s, _) =>
805 (print ("System error: "^ s ^ "\n");
806 OpenSSL.close bio
807 handle OpenSSL.OpenSSL _ => ();
808 loop ())
07cc384c 809 in
3b267643
AC
810 loop ();
811 OpenSSL.shutdown sock
07cc384c
AC
812 end
813
44a5ce2f 814fun listBasis () =
3196000d
AC
815 let
816 val dir = Posix.FileSys.opendir Config.libRoot
817
818 fun loop files =
819 case Posix.FileSys.readdir dir of
820 NONE => (Posix.FileSys.closedir dir;
821 files)
822 | SOME fname =>
823 if String.isSuffix ".dtl" fname then
824 loop (OS.Path.joinDirFile {dir = Config.libRoot,
825 file = fname}
826 :: files)
827 else
828 loop files
3196000d 829 in
44a5ce2f 830 loop []
3196000d
AC
831 end
832
44a5ce2f
AC
833fun autodocBasis outdir =
834 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
835
234b917a 836end