Start of DBMS support

[hcoop/domtool2.git] / src / main.sml

diff --git a/src/main.sml b/src/main.sml
index 7457545..f2a45c7 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -386,6 +386,21 @@ fun requestRmuser user =
        OpenSSL.close bio
     end
 
        OpenSSL.close bio
     end
 

+fun requestDbUser dbtype =
+    let
+       val (_, bio) = requestBio (fn () => ())
+    in
+       Msg.send (bio, MsgCreateDbUser dbtype);
+       case Msg.recv bio of
+           NONE => print "Server closed connection unexpectedly.\n"
+         | SOME m =>
+           case m of
+               MsgOk => print "Your user has been created.\n"
+             | MsgError s => print ("Creation failed: " ^ s ^ "\n")
+             | _ => print "Unexpected server reply.\n";
+       OpenSSL.close bio
+    end
+

 fun regenerate context =
     let
        val b = basis ()
 fun regenerate context =
     let
        val b = basis ()


@@ -683,7 +698,37 @@ fun service () =
                                      ignore (OpenSSL.readChar bio);
                                      OpenSSL.close bio)
                                     handle OpenSSL.OpenSSL _ => ();
                                      ignore (OpenSSL.readChar bio);
                                      OpenSSL.close bio)
                                     handle OpenSSL.OpenSSL _ => ();

-                                    loop ())                           
+                                    loop ())
+
+                             | MsgCreateDbUser dbtype =>
+                               (case Dbms.lookup dbtype of
+                                    NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype));
+                                              print ("Database user creation request with unknown datatype type " ^ dbtype);
+                                              ignore (OpenSSL.readChar bio))
+                                             handle OpenSSL.OpenSSL _ => ();
+                                             OpenSSL.close bio
+                                             handle OpenSSL.OpenSSL _ => ();
+                                             loop ())
+                                  | SOME handler =>
+                                    case #adduser handler user of
+                                        NONE => ((Msg.send (bio, MsgOk);
+                                                  print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n"))
+                                                 handle OpenSSL.OpenSSL s =>
+                                                        (print "OpenSSL error\n";
+                                                         Msg.send (bio,
+                                                                   MsgError
+                                                                       ("Error during creation: "
+                                                                        ^ s)));
+                                                 (ignore (OpenSSL.readChar bio);
+                                                  OpenSSL.close bio)
+                                                 handle OpenSSL.OpenSSL _ => ();
+                                                 loop ())
+                                      | SOME msg => ((Msg.send (bio, MsgError ("Error adding user: " ^ msg));
+                                                      print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n");
+                                                      ignore (OpenSSL.readChar bio);
+                                                      OpenSSL.close bio)
+                                                     handle OpenSSL.OpenSSL _ => ();
+                                                     loop ()))

 
                              | _ =>
                                (Msg.send (bio, MsgError "Unexpected command")
 
                              | _ =>
                                (Msg.send (bio, MsgError "Unexpected command")