DBMS database creation
[hcoop/zz_old/domtool2-proto.git] / src / main.sml
CommitLineData
e680130a 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.
ae3a5b8c 17 *)
e680130a 18
19(* Main interface *)
20
21structure Main :> MAIN = struct
22
d330d9b8 23open Ast MsgTypes Print
e680130a 24
85af7d3e 25structure SM = StringMap
26
53d222a3 27fun init () = Acl.read Config.aclFile
e680130a 28
17ef447e 29fun check' G fname =
a11c0ff3 30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
17ef447e 34 G
a11c0ff3 35 else
53d222a3 36 Tycheck.checkFile G (Defaults.tInit ()) prog
a11c0ff3 37 end
38
17ef447e 39fun basis () =
e680130a 40 let
17ef447e 41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
c12828f2 45 NONE => (Posix.FileSys.closedir dir;
46 files)
17ef447e 47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
c12828f2 49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
17ef447e 51 :: files)
52 else
53 loop files
54
55 val files = loop []
c8a739af 56 val (_, files) = Order.order NONE files
17ef447e 57 in
85af7d3e 58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
89c9edc9 61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
17ef447e 64 end
65
66fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
4e8a3f2b 69 val _ = Env.preTycheck ()
17ef447e 70
71 val b = basis ()
e680130a 72 in
73 if !ErrorMsg.anyErrors then
d330d9b8 74 raise ErrorMsg.Error
e680130a 75 else
76 let
89c9edc9 77 val _ = Tycheck.disallowExterns ()
4cc63b03 78 val _ = ErrorMsg.reset ()
17ef447e 79 val prog = Parse.parse fname
e680130a 80 in
add6f172 81 if !ErrorMsg.anyErrors then
d330d9b8 82 raise ErrorMsg.Error
add6f172 83 else
17ef447e 84 let
53d222a3 85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
17ef447e 86 in
d330d9b8 87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
17ef447e 91 end
e680130a 92 end
93 end
94
c8a739af 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
f92c6883 119 raise ErrorMsg.Error
c8a739af 120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
f92c6883 122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
c8a739af 126 end
127
17ef447e 128fun reduce fname =
a11c0ff3 129 let
17ef447e 130 val (G, body) = check fname
a11c0ff3 131 in
132 if !ErrorMsg.anyErrors then
17ef447e 133 NONE
a11c0ff3 134 else
17ef447e 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
a11c0ff3 147 end
148
17ef447e 149fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
d330d9b8 153 raise ErrorMsg.Error
17ef447e 154 else
53d222a3 155 Eval.exec (Defaults.eInit ()) body'
d330d9b8 156 | NONE => raise ErrorMsg.Error
17ef447e 157
f92c6883 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
2569e66d 167val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
1f8889bd 169
e2130d9c 170fun requestContext f =
904eb905 171 let
3ff08fe1 172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
e2130d9c 174
3ff08fe1 175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
e2130d9c 177
178 val () = f ()
53d222a3 179
53d222a3 180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
514b7936 181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
2569e66d 182 Config.trustStore)
e2130d9c 183 in
184 (user, context)
185 end
904eb905 186
e2130d9c 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))
1f8889bd 197
2569e66d 198 val inf = TextIO.openIn fname
199
d330d9b8 200 fun loop lines =
2569e66d 201 case TextIO.inputLine inf of
d330d9b8 202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
1f8889bd 206 in
2569e66d 207 TextIO.closeIn inf;
d330d9b8 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";
2569e66d 216 OpenSSL.close bio
1f8889bd 217 end
53d222a3 218 handle ErrorMsg.Error => ()
1f8889bd 219
c8a739af 220fun requestDir dname =
221 let
f92c6883 222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
c8a739af 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
f92c6883 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)
c8a739af 275 end
276 handle ErrorMsg.Error => ()
277
e2130d9c 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
d1aa6a21 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
646381db 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
d0e75410 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
f92c6883 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
7d32cf2f 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
aba1f07e 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
634d7082 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
d34cbcb8 404fun requestDbTable p =
405 let
406 val (user, bio) = requestBio (fn () => ())
407 in
408 Msg.send (bio, MsgCreateDbTable p);
409 case Msg.recv bio of
410 NONE => print "Server closed connection unexpectedly.\n"
411 | SOME m =>
412 case m of
413 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
414 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
415 | _ => print "Unexpected server reply.\n";
416 OpenSSL.close bio
417 end
418
0ea0ecfa 419fun regenerate context =
f92c6883 420 let
421 val b = basis ()
0ea0ecfa 422 val () = Tycheck.disallowExterns ()
423
424 val () = Domain.resetGlobal ()
425
426 fun contactNode (node, ip) =
427 if node = Config.defaultNode then
428 Domain.resetLocal ()
429 else let
430 val bio = OpenSSL.connect (context,
431 ip
432 ^ ":"
433 ^ Int.toString Config.slavePort)
434 in
435 Msg.send (bio, MsgRegenerate);
436 case Msg.recv bio of
437 NONE => print "Slave closed connection unexpectedly\n"
438 | SOME m =>
439 case m of
440 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
441 | MsgError s => print ("Slave " ^ node
442 ^ " returned error: " ^
443 s ^ "\n")
444 | _ => print ("Slave " ^ node
445 ^ " returned unexpected command\n");
446 OpenSSL.close bio
447 end
f92c6883 448
449 fun doUser user =
450 let
451 val _ = Domain.setUser user
452 val _ = ErrorMsg.reset ()
453
454 val dname = Config.domtoolDir user
455
456 val dir = Posix.FileSys.opendir dname
457
458 fun loop files =
459 case Posix.FileSys.readdir dir of
460 NONE => (Posix.FileSys.closedir dir;
461 files)
462 | SOME fname =>
463 if notTmp fname then
464 loop (OS.Path.joinDirFile {dir = dname,
465 file = fname}
466 :: files)
467 else
468 loop files
469
470 val files = loop []
471 val (_, files) = Order.order (SOME b) files
472 in
473 if !ErrorMsg.anyErrors then
474 print ("User " ^ user ^ "'s configuration has errors!\n")
475 else
476 app eval' files
477 end
478 handle IO.Io _ => ()
479 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
480 in
0ea0ecfa 481 app contactNode Config.nodeIps;
f92c6883 482 Env.pre ();
483 app doUser (Acl.users ());
484 Env.post ()
485 end
486
aba1f07e 487fun rmuser user =
488 let
489 val doms = Acl.class {user = user, class = "domain"}
490 val doms = List.filter (fn dom =>
491 case Acl.whoHas {class = "domain", value = dom} of
492 [_] => true
493 | _ => false) (StringSet.listItems doms)
494 in
495 Acl.rmuser user;
496 Domain.rmdom doms
497 end
498
2569e66d 499fun service () =
904eb905 500 let
53d222a3 501 val () = Acl.read Config.aclFile
502
2569e66d 503 val context = OpenSSL.context (Config.serverCert,
504 Config.serverKey,
505 Config.trustStore)
d330d9b8 506 val _ = Domain.set_context context
2569e66d 507
cbb8f260 508 val sock = OpenSSL.listen (context, Config.dispatcherPort)
2569e66d 509
510 fun loop () =
cbb8f260 511 case OpenSSL.accept sock of
2569e66d 512 NONE => ()
513 | SOME bio =>
514 let
53d222a3 515 val user = OpenSSL.peerCN bio
516 val () = print ("\nConnection from " ^ user ^ "\n")
517 val () = Domain.setUser user
518
c8a739af 519 fun doConfig codes =
520 let
521 val _ = print "Configuration:\n"
522 val _ = app (fn s => (print s; print "\n")) codes
523 val _ = print "\n"
524
525 val outname = OS.FileSys.tmpName ()
526
527 fun doOne code =
528 let
529 val outf = TextIO.openOut outname
530 in
531 TextIO.output (outf, code);
532 TextIO.closeOut outf;
f92c6883 533 eval' outname
c8a739af 534 end
535 in
f92c6883 536 (Env.pre ();
537 app doOne codes;
538 Env.post ();
c8a739af 539 Msg.send (bio, MsgOk))
540 handle ErrorMsg.Error =>
541 (print "Compilation error\n";
542 Msg.send (bio,
543 MsgError "Error during configuration evaluation"))
544 | OpenSSL.OpenSSL s =>
545 (print "OpenSSL error\n";
546 Msg.send (bio,
547 MsgError
548 ("Error during configuration evaluation: "
549 ^ s)));
550 OS.FileSys.remove outname;
551 (ignore (OpenSSL.readChar bio);
552 OpenSSL.close bio)
553 handle OpenSSL.OpenSSL _ => ();
554 loop ()
555 end
556
d330d9b8 557 fun cmdLoop () =
558 case Msg.recv bio of
559 NONE => (OpenSSL.close bio
560 handle OpenSSL.OpenSSL _ => ();
561 loop ())
562 | SOME m =>
563 case m of
c8a739af 564 MsgConfig code => doConfig [code]
565 | MsgMultiConfig codes => doConfig codes
e2130d9c 566
567 | MsgGrant acl =>
1bb29dea 568 if Acl.query {user = user, class = "priv", value = "all"} then
e2130d9c 569 ((Acl.grant acl;
570 Acl.write Config.aclFile;
d1aa6a21 571 Msg.send (bio, MsgOk);
572 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
e2130d9c 573 handle OpenSSL.OpenSSL s =>
574 (print "OpenSSL error\n";
575 Msg.send (bio,
576 MsgError
577 ("Error during granting: "
578 ^ s)));
579 (ignore (OpenSSL.readChar bio);
580 OpenSSL.close bio)
581 handle OpenSSL.OpenSSL _ => ();
582 loop ())
583 else
584 ((Msg.send (bio, MsgError "Not authorized to grant privileges");
d1aa6a21 585 print "Unauthorized user asked to grant a permission!\n";
586 ignore (OpenSSL.readChar bio);
587 OpenSSL.close bio)
588 handle OpenSSL.OpenSSL _ => ();
589 loop ())
590
591 | MsgRevoke acl =>
1bb29dea 592 if Acl.query {user = user, class = "priv", value = "all"} then
d1aa6a21 593 ((Acl.revoke acl;
594 Acl.write Config.aclFile;
595 Msg.send (bio, MsgOk);
596 print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
597 handle OpenSSL.OpenSSL s =>
598 (print "OpenSSL error\n";
599 Msg.send (bio,
600 MsgError
601 ("Error during revocation: "
602 ^ s)));
603 (ignore (OpenSSL.readChar bio);
604 OpenSSL.close bio)
605 handle OpenSSL.OpenSSL _ => ();
606 loop ())
607 else
608 ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
609 print "Unauthorized user asked to revoke a permission!\n";
e2130d9c 610 ignore (OpenSSL.readChar bio);
611 OpenSSL.close bio)
612 handle OpenSSL.OpenSSL _ => ();
613 loop ())
614
646381db 615 | MsgListPerms user =>
616 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
617 print ("Sent permission list for user " ^ user ^ ".\n"))
618 handle OpenSSL.OpenSSL s =>
619 (print "OpenSSL error\n";
620 Msg.send (bio,
621 MsgError
622 ("Error during permission listing: "
623 ^ s)));
624 (ignore (OpenSSL.readChar bio);
625 OpenSSL.close bio)
626 handle OpenSSL.OpenSSL _ => ();
627 loop ())
628
d0e75410 629 | MsgWhoHas perm =>
630 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
631 print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
632 handle OpenSSL.OpenSSL s =>
633 (print "OpenSSL error\n";
634 Msg.send (bio,
635 MsgError
636 ("Error during whohas: "
637 ^ s)));
638 (ignore (OpenSSL.readChar bio);
639 OpenSSL.close bio)
640 handle OpenSSL.OpenSSL _ => ();
641 loop ())
642
aba1f07e 643 | MsgRmdom doms =>
7d32cf2f 644 if Acl.query {user = user, class = "priv", value = "all"}
aba1f07e 645 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
646 ((Domain.rmdom doms;
647 app (fn dom =>
648 Acl.revokeFromAll {class = "domain", value = dom}) doms;
649 Acl.write Config.aclFile;
7d32cf2f 650 Msg.send (bio, MsgOk);
aba1f07e 651 print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n"))
7d32cf2f 652 handle OpenSSL.OpenSSL s =>
653 (print "OpenSSL error\n";
654 Msg.send (bio,
655 MsgError
656 ("Error during revocation: "
657 ^ s)));
658 (ignore (OpenSSL.readChar bio);
659 OpenSSL.close bio)
660 handle OpenSSL.OpenSSL _ => ();
661 loop ())
662 else
663 ((Msg.send (bio, MsgError "Not authorized to remove that domain");
664 print "Unauthorized user asked to remove a domain!\n";
665 ignore (OpenSSL.readChar bio);
666 OpenSSL.close bio)
667 handle OpenSSL.OpenSSL _ => ();
f92c6883 668 loop ())
669
670 | MsgRegenerate =>
671 if Acl.query {user = user, class = "priv", value = "regen"}
672 orelse Acl.query {user = user, class = "priv", value = "all"} then
0ea0ecfa 673 ((regenerate context;
f92c6883 674 Msg.send (bio, MsgOk);
675 print "Regenerated all configuration.\n")
676 handle OpenSSL.OpenSSL s =>
677 (print "OpenSSL error\n";
678 Msg.send (bio,
679 MsgError
680 ("Error during regeneration: "
681 ^ s)));
682 (ignore (OpenSSL.readChar bio);
683 OpenSSL.close bio)
684 handle OpenSSL.OpenSSL _ => ();
685 loop ())
686 else
687 ((Msg.send (bio, MsgError "Not authorized to regeneration");
688 print "Unauthorized user asked to regenerate!\n";
689 ignore (OpenSSL.readChar bio);
690 OpenSSL.close bio)
691 handle OpenSSL.OpenSSL _ => ();
aba1f07e 692 loop ())
693
6eee5b5c 694 | MsgRmuser user' =>
aba1f07e 695 if Acl.query {user = user, class = "priv", value = "all"} then
6eee5b5c 696 ((rmuser user';
aba1f07e 697 Acl.write Config.aclFile;
698 Msg.send (bio, MsgOk);
6eee5b5c 699 print ("Removed user " ^ user' ^ ".\n"))
aba1f07e 700 handle OpenSSL.OpenSSL s =>
701 (print "OpenSSL error\n";
702 Msg.send (bio,
703 MsgError
704 ("Error during revocation: "
705 ^ s)));
706 (ignore (OpenSSL.readChar bio);
707 OpenSSL.close bio)
708 handle OpenSSL.OpenSSL _ => ();
709 loop ())
710 else
711 ((Msg.send (bio, MsgError "Not authorized to remove users");
712 print "Unauthorized user asked to remove a user!\n";
713 ignore (OpenSSL.readChar bio);
714 OpenSSL.close bio)
715 handle OpenSSL.OpenSSL _ => ();
634d7082 716 loop ())
717
718 | MsgCreateDbUser dbtype =>
719 (case Dbms.lookup dbtype of
720 NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
721 print ("Database user creation request with unknown datatype type " ^ dbtype);
722 ignore (OpenSSL.readChar bio))
723 handle OpenSSL.OpenSSL _ => ();
724 OpenSSL.close bio
725 handle OpenSSL.OpenSSL _ => ();
726 loop ())
727 | SOME handler =>
728 case #adduser handler user of
729 NONE => ((Msg.send (bio, MsgOk);
730 print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n"))
731 handle OpenSSL.OpenSSL s =>
732 (print "OpenSSL error\n";
733 Msg.send (bio,
734 MsgError
735 ("Error during creation: "
736 ^ s)));
737 (ignore (OpenSSL.readChar bio);
738 OpenSSL.close bio)
739 handle OpenSSL.OpenSSL _ => ();
740 loop ())
741 | SOME msg => ((Msg.send (bio, MsgError ("Error adding user: " ^ msg));
742 print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n");
743 ignore (OpenSSL.readChar bio);
744 OpenSSL.close bio)
745 handle OpenSSL.OpenSSL _ => ();
746 loop ()))
7d32cf2f 747
d34cbcb8 748 | MsgCreateDbTable {dbtype, dbname} =>
749 if Dbms.validDbname dbname then
750 (case Dbms.lookup dbtype of
751 NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
752 print ("Database creation request with unknown datatype type " ^ dbtype);
753 ignore (OpenSSL.readChar bio))
754 handle OpenSSL.OpenSSL _ => ();
755 OpenSSL.close bio
756 handle OpenSSL.OpenSSL _ => ();
757 loop ())
758 | SOME handler =>
759 case #createdb handler {user = user, dbname = dbname} of
760 NONE => ((Msg.send (bio, MsgOk);
761 print ("Created database " ^ user ^ "_" ^ dbname ^ ".\n"))
762 handle OpenSSL.OpenSSL s =>
763 (print "OpenSSL error\n";
764 Msg.send (bio,
765 MsgError
766 ("Error during creation: "
767 ^ s)));
768 (ignore (OpenSSL.readChar bio);
769 OpenSSL.close bio)
770 handle OpenSSL.OpenSSL _ => ();
771 loop ())
772 | SOME msg => ((Msg.send (bio, MsgError ("Error creating database: " ^ msg));
773 print ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg ^ "\n");
774 ignore (OpenSSL.readChar bio);
775 OpenSSL.close bio)
776 handle OpenSSL.OpenSSL _ => ();
777 loop ()))
778 else
779 ((Msg.send (bio, MsgError ("Invalid database name " ^ dbname));
780 print ("Invalid database name " ^ user ^ "_" ^ dbname ^ "\n");
781 ignore (OpenSSL.readChar bio);
782 OpenSSL.close bio)
783 handle OpenSSL.OpenSSL _ => ();
784 loop ())
785
d330d9b8 786 | _ =>
787 (Msg.send (bio, MsgError "Unexpected command")
788 handle OpenSSL.OpenSSL _ => ();
789 OpenSSL.close bio
790 handle OpenSSL.OpenSSL _ => ();
791 loop ())
792 in
793 cmdLoop ()
794 end
7e90e261 795 handle OpenSSL.OpenSSL s =>
796 (print ("OpenSSL error: " ^ s ^ "\n");
797 OpenSSL.close bio
798 handle OpenSSL.OpenSSL _ => ();
799 loop ())
800 | OS.SysErr (s, _) =>
801 (print ("System error: " ^ s ^ "\n");
802 OpenSSL.close bio
803 handle OpenSSL.OpenSSL _ => ();
804 loop ())
d330d9b8 805 in
0cfb3669 806 print "Listening for connections....\n";
d330d9b8 807 loop ();
808 OpenSSL.shutdown sock
809 end
810
811fun slave () =
812 let
f58a3627 813 val host = Slave.hostname ()
d330d9b8 814
815 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
514b7936 816 Config.keyDir ^ "/" ^ host ^ "/key.pem",
d330d9b8 817 Config.trustStore)
818
819 val sock = OpenSSL.listen (context, Config.slavePort)
820
821 fun loop () =
822 case OpenSSL.accept sock of
823 NONE => ()
824 | SOME bio =>
825 let
826 val peer = OpenSSL.peerCN bio
827 val () = print ("\nConnection from " ^ peer ^ "\n")
2569e66d 828 in
d330d9b8 829 if peer <> Config.dispatcherName then
830 (print "Not authorized!\n";
831 OpenSSL.close bio;
832 loop ())
833 else let
834 fun loop' files =
835 case Msg.recv bio of
836 NONE => print "Dispatcher closed connection unexpectedly\n"
837 | SOME m =>
838 case m of
839 MsgFile file => loop' (file :: files)
840 | MsgDoFiles => (Slave.handleChanges files;
841 Msg.send (bio, MsgOk))
0ea0ecfa 842 | MsgRegenerate => (Domain.resetLocal ();
843 Msg.send (bio, MsgOk))
d330d9b8 844 | _ => (print "Dispatcher sent unexpected command\n";
845 Msg.send (bio, MsgError "Unexpected command"))
846 in
847 loop' [];
848 ignore (OpenSSL.readChar bio);
849 OpenSSL.close bio;
850 loop ()
851 end
91c5a390 852 end handle OpenSSL.OpenSSL s =>
853 (print ("OpenSSL error: "^ s ^ "\n");
854 OpenSSL.close bio
855 handle OpenSSL.OpenSSL _ => ();
856 loop ())
1d2fd26b 857 | OS.SysErr (s, _) =>
858 (print ("System error: "^ s ^ "\n");
859 OpenSSL.close bio
860 handle OpenSSL.OpenSSL _ => ();
861 loop ())
904eb905 862 in
2569e66d 863 loop ();
864 OpenSSL.shutdown sock
904eb905 865 end
866
e26d6b6e 867fun listBasis () =
91c5a390 868 let
869 val dir = Posix.FileSys.opendir Config.libRoot
870
871 fun loop files =
872 case Posix.FileSys.readdir dir of
873 NONE => (Posix.FileSys.closedir dir;
874 files)
875 | SOME fname =>
876 if String.isSuffix ".dtl" fname then
877 loop (OS.Path.joinDirFile {dir = Config.libRoot,
878 file = fname}
879 :: files)
880 else
881 loop files
91c5a390 882 in
e26d6b6e 883 loop []
91c5a390 884 end
885
e26d6b6e 886fun autodocBasis outdir =
887 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
888
e680130a 889end