Add MySQL skeleton
[hcoop/domtool2.git] / src / main.sml
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.
17 *)
18
19 (* Main interface *)
20
21 structure Main :> MAIN = struct
22
23 open Ast MsgTypes Print
24
25 structure SM = StringMap
26
27 fun init () = Acl.read Config.aclFile
28
29 fun check' G fname =
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
34 G
35 else
36 Tycheck.checkFile G (Defaults.tInit ()) prog
37 end
38
39 fun basis () =
40 let
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
45 NONE => (Posix.FileSys.closedir dir;
46 files)
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
51 :: files)
52 else
53 loop files
54
55 val files = loop []
56 val (_, files) = Order.order NONE files
57 in
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
64 end
65
66 fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
69 val _ = Env.preTycheck ()
70
71 val b = basis ()
72 in
73 if !ErrorMsg.anyErrors then
74 raise ErrorMsg.Error
75 else
76 let
77 val _ = Tycheck.disallowExterns ()
78 val _ = ErrorMsg.reset ()
79 val prog = Parse.parse fname
80 in
81 if !ErrorMsg.anyErrors then
82 raise ErrorMsg.Error
83 else
84 let
85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
86 in
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
91 end
92 end
93 end
94
95 val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97 fun 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
119 raise ErrorMsg.Error
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
126 end
127
128 fun reduce fname =
129 let
130 val (G, body) = check fname
131 in
132 if !ErrorMsg.anyErrors then
133 NONE
134 else
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
147 end
148
149 fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
153 raise ErrorMsg.Error
154 else
155 Eval.exec (Defaults.eInit ()) body'
156 | NONE => raise ErrorMsg.Error
157
158 fun 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
167 val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
169
170 fun requestContext f =
171 let
172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
174
175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
177
178 val () = f ()
179
180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
182 Config.trustStore)
183 in
184 (user, context)
185 end
186
187 fun requestBio f =
188 let
189 val (user, context) = requestContext f
190 in
191 (user, OpenSSL.connect (context, dispatcher))
192 end
193
194 fun request fname =
195 let
196 val (user, bio) = requestBio (fn () => ignore (check fname))
197
198 val inf = TextIO.openIn fname
199
200 fun loop lines =
201 case TextIO.inputLine inf of
202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
206 in
207 TextIO.closeIn inf;
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";
216 OpenSSL.close bio
217 end
218 handle ErrorMsg.Error => ()
219
220 fun requestDir dname =
221 let
222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
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
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)
275 end
276 handle ErrorMsg.Error => ()
277
278 fun 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
293 fun 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
308 fun 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
326 fun 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
344 fun 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
359 fun 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
374 fun 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
389 fun 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
404 fun 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
419 fun regenerate context =
420 let
421 val b = basis ()
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
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
481 app contactNode Config.nodeIps;
482 Env.pre ();
483 app doUser (Acl.users ());
484 Env.post ()
485 end
486
487 fun 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
499 fun service () =
500 let
501 val () = Acl.read Config.aclFile
502
503 val context = OpenSSL.context (Config.serverCert,
504 Config.serverKey,
505 Config.trustStore)
506 val _ = Domain.set_context context
507
508 val sock = OpenSSL.listen (context, Config.dispatcherPort)
509
510 fun loop () =
511 case OpenSSL.accept sock of
512 NONE => ()
513 | SOME bio =>
514 let
515 val user = OpenSSL.peerCN bio
516 val () = print ("\nConnection from " ^ user ^ "\n")
517 val () = Domain.setUser user
518
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;
533 eval' outname
534 end
535 in
536 (Env.pre ();
537 app doOne codes;
538 Env.post ();
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
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
564 MsgConfig code => doConfig [code]
565 | MsgMultiConfig codes => doConfig codes
566
567 | MsgGrant acl =>
568 if Acl.query {user = user, class = "priv", value = "all"} then
569 ((Acl.grant acl;
570 Acl.write Config.aclFile;
571 Msg.send (bio, MsgOk);
572 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
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");
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 =>
592 if Acl.query {user = user, class = "priv", value = "all"} then
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";
610 ignore (OpenSSL.readChar bio);
611 OpenSSL.close bio)
612 handle OpenSSL.OpenSSL _ => ();
613 loop ())
614
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
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
643 | MsgRmdom doms =>
644 if Acl.query {user = user, class = "priv", value = "all"}
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;
650 Msg.send (bio, MsgOk);
651 print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n"))
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 _ => ();
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
673 ((regenerate context;
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 _ => ();
692 loop ())
693
694 | MsgRmuser user' =>
695 if Acl.query {user = user, class = "priv", value = "all"} then
696 ((rmuser user';
697 Acl.write Config.aclFile;
698 Msg.send (bio, MsgOk);
699 print ("Removed user " ^ user' ^ ".\n"))
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 _ => ();
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 ()))
747
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
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
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 ())
805 in
806 print "Listening for connections....\n";
807 loop ();
808 OpenSSL.shutdown sock
809 end
810
811 fun slave () =
812 let
813 val host = Slave.hostname ()
814
815 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
816 Config.keyDir ^ "/" ^ host ^ "/key.pem",
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")
828 in
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))
842 | MsgRegenerate => (Domain.resetLocal ();
843 Msg.send (bio, MsgOk))
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
852 end handle OpenSSL.OpenSSL s =>
853 (print ("OpenSSL error: "^ s ^ "\n");
854 OpenSSL.close bio
855 handle OpenSSL.OpenSSL _ => ();
856 loop ())
857 | OS.SysErr (s, _) =>
858 (print ("System error: "^ s ^ "\n");
859 OpenSSL.close bio
860 handle OpenSSL.OpenSSL _ => ();
861 loop ())
862 in
863 loop ();
864 OpenSSL.shutdown sock
865 end
866
867 fun listBasis () =
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
882 in
883 loop []
884 end
885
886 fun autodocBasis outdir =
887 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
888
889 end