Start CH node for onvm run

edsko · edsko · commit 06237a3e8cdc · 2012-07-31T17:35:13.000+01:00
We pass the wrong IP address at the moment; we need to figure out how to find
the right one
diff --git a/distributed-process-azure/distributed-process-azure.cabal b/distributed-process-azure/distributed-process-azure.cabal
@@ -38,4 +38,7 @@ Executable cloud-haskell-azure
                      libssh2 >= 0.2 && < 0.3,
                      filepath >= 1.3 && < 1.4,
                      distributed-process-azure >= 0.1 && < 0.2,
-                     optparse-applicative >= 0.2 && < 0.4
+                     optparse-applicative >= 0.2 && < 0.4,
+                     distributed-process >= 0.2 && < 0.3,
+                     transformers >= 0.3 && < 0.4,
+                     network-transport-tcp >= 0.2 && < 0.3
diff --git a/distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs b/distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs
@@ -114,13 +114,15 @@ apiCopyToVM params vm =
 
 -- | Start the executable on the remote machine
 apiRunOnVM :: AzureParameters -> VirtualMachine -> IO ()
-apiRunOnVM params vm =
+apiRunOnVM params vm@(Azure.vmSshEndpoint -> Just ep) =
   void . withSSH2 params vm $ \fd s -> do
-    let exe = "/home/edsko/" ++ azureSshRemotePath params
+    let exe = "/home/edsko/" ++ azureSshRemotePath params 
+           ++ " onvm run "
+           ++ " --host " ++ endpointVip ep
+           ++ " --port 8080 "
+           ++ "2>&1"
     putStrLn $ "Executing " ++ show exe
-    r <- SSH.execCommands fd s [exe ++ " onvm run "
-                                    ++ "2>&1"
-                               ] -- ++ " >/dev/null 2>&1 &"]  /usr/bin/nohup 
+    r <- SSH.execCommands fd s [exe] -- ++ " >/dev/null 2>&1 &"]  /usr/bin/nohup 
     print r
 
 -- | Check the MD5 hash of the executable on the remote machine
diff --git a/distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs b/distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs
@@ -2,7 +2,9 @@ import System.Environment (getArgs)
 import System.Exit (exitSuccess, exitFailure)
 import System.IO (hFlush, stdout)
 import Control.Monad (unless, forM, forM_)
+import Control.Monad.IO.Class (liftIO)
 import Control.Arrow (returnA)
+import Control.Exception (throwIO)
 import Control.Distributed.Process.Backend.Azure 
   ( AzureParameters(azureSshUserName)
   , defaultAzureParameters
@@ -35,6 +37,9 @@ import Options.Applicative
   , switch
   )
 import Options.Applicative.Arrows (runA, asA)
+import Control.Distributed.Process (getSelfPid, RemoteTable)
+import Control.Distributed.Process.Node (newLocalNode, runProcess, initRemoteTable)
+import Network.Transport.TCP (createTransport, defaultTCPParameters)
 
 --------------------------------------------------------------------------------
 -- Command line options                                                       --
@@ -83,7 +88,10 @@ data Command =
   deriving Show
 
 data OnVmCommand =
-    OnVmRun
+    OnVmRun {
+      onVmIP   :: String
+    , onVmPort :: String
+    }
   deriving Show
 
 azureOptionsParser :: Parser AzureOptions
@@ -161,7 +169,15 @@ runOnParser = RunOn
   <*> targetParser 
 
 onVmRunParser :: Parser OnVmCommand
-onVmRunParser = pure OnVmRun 
+onVmRunParser = OnVmRun 
+  <$> strOption ( long "host"
+                & metavar "IP"
+                & help "IP address"
+                )
+  <*> strOption ( long "port"
+                & metavar "PORT"
+                & help "port number"
+                )
 
 onVmCommandParser :: Parser Command
 onVmCommandParser = OnVmCommand <$> subparser
@@ -212,7 +228,8 @@ main = do
           runOnVM backend vm 
           putStrLn "Done"
       OnVmCommand (vmCmd@OnVmRun {}) -> do
-        putStrLn "Hello" 
+        let rtable = initRemoteTable
+        onVmRun rtable (onVmIP vmCmd) (onVmPort vmCmd)
     SSH.exit
   where
     opts = info (helper <*> commandParser)
@@ -240,3 +257,16 @@ azureParameters opts (Just sshOpts) = do
   return params { 
       azureSshUserName = remoteUser sshOpts
     }
+
+onVmRun :: RemoteTable -> String -> String -> IO ()
+onVmRun rtable host port = do
+  mTransport <- createTransport host port defaultTCPParameters 
+  case mTransport of
+    Left err -> throwIO err
+    Right transport -> do
+      node <- newLocalNode transport rtable
+      runProcess node $ do
+        pid <- getSelfPid
+        liftIO . putStrLn $ "Azure controller has pid " ++ show pid
+  
+  
