@@ -1,10 +1,19 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+import Prelude hiding (catch)
13import System.Environment (getArgs)
24import System.Exit (exitSuccess, exitFailure)
3−import System.IO (hFlush, stdout)
4−import Control.Monad (unless, forM, forM_)
5+import System.IO
6+ ( hFlush
7+ , stdout
8+ , stdin
9+ , hSetBinaryMode
10+ )
11+import Data.Binary (decode)
12+import qualified Data.ByteString.Lazy as BSL (ByteString, length, getContents)
13+import Control.Monad (unless, forM, forM_, join)
514import Control.Monad.IO.Class (liftIO)
615import Control.Arrow (returnA)
7−import Control.Exception (throwIO)
16+import Control.Exception (throwIO, SomeException)
817import Control.Distributed.Process.Backend.Azure
918 ( AzureParameters(azureSshUserName)
1019 , defaultAzureParameters
@@ -37,10 +46,109 @@ import Options.Applicative
3746 , switch
3847 )
3948import Options.Applicative.Arrows (runA, asA)
40−import Control.Distributed.Process (getSelfPid, RemoteTable)
49+import Control.Distributed.Process
50+ ( getSelfPid
51+ , RemoteTable
52+ , Closure
53+ , Process
54+ , unClosure
55+ , catch
56+ )
57+import Control.Distributed.Process.Closure (remotable, mkClosure)
4158import Control.Distributed.Process.Node (newLocalNode, runProcess, initRemoteTable)
4259import Network.Transport.TCP (createTransport, defaultTCPParameters)
4360
61+cprint :: String -> Process ()
62+cprint = liftIO . putStrLn
63+
64+remotable ['cprint]
65+
66+--------------------------------------------------------------------------------
67+-- Main --
68+--------------------------------------------------------------------------------
69+
70+main :: IO ()
71+main = do
72+ _ <- SSH.initialize True
73+ cmd <- execParser opts
74+ case cmd of
75+ List {} -> do
76+ params <- azureParameters (azureOptions cmd) Nothing
77+ backend <- initializeBackend params
78+ css <- cloudServices backend
79+ mapM_ print css
80+ CopyTo {} -> do
81+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
82+ backend <- initializeBackend params
83+ css <- cloudServices backend
84+ forM_ (findTarget (target cmd) css) $ \vm -> do
85+ putStr (vmName vm ++ ": ") >> hFlush stdout
86+ copyToVM backend vm
87+ putStrLn "Done"
88+ CheckMD5 {} -> do
89+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
90+ backend <- initializeBackend params
91+ css <- cloudServices backend
92+ matches <- forM (findTarget (target cmd) css) $ \vm -> do
93+ unless (status cmd) $ putStr (vmName vm ++ ": ") >> hFlush stdout
94+ match <- checkMD5 backend vm
95+ unless (status cmd) $ putStrLn $ if match then "OK" else "FAILED"
96+ return match
97+ if and matches
98+ then exitSuccess
99+ else exitFailure
100+ RunOn {} -> do
101+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
102+ backend <- initializeBackend params
103+ css <- cloudServices backend
104+ forM_ (findTarget (target cmd) css) $ \vm -> do
105+ putStr (vmName vm ++ ": ") >> hFlush stdout
106+ runOnVM backend vm (port cmd) ($(mkClosure 'cprint) "Hello world")
107+ OnVmCommand (vmCmd@OnVmRun {}) -> do
108+ let rtable = __remoteTable initRemoteTable
109+ onVmRun rtable (onVmIP vmCmd) (onVmPort vmCmd)
110+ SSH.exit
111+ where
112+ opts = info (helper <*> commandParser)
113+ ( fullDesc
114+ & header "Cloud Haskell backend for Azure"
115+ )
116+
117+findTarget :: Target -> [CloudService] -> [VirtualMachine]
118+findTarget (CloudService cs) css =
119+ concatMap cloudServiceVMs . filter ((== cs) . cloudServiceName) $ css
120+findTarget (VirtualMachine virtualMachine) css =
121+ [ vm | vm <- concatMap cloudServiceVMs css
122+ , vmName vm == virtualMachine
123+ ]
124+
125+azureParameters :: AzureOptions -> Maybe SshOptions -> IO AzureParameters
126+azureParameters opts Nothing =
127+ defaultAzureParameters (subscriptionId opts)
128+ (pathToCert opts)
129+ (pathToKey opts)
130+azureParameters opts (Just sshOpts) = do
131+ params <- defaultAzureParameters (subscriptionId opts)
132+ (pathToCert opts)
133+ (pathToKey opts)
134+ return params {
135+ azureSshUserName = remoteUser sshOpts
136+ }
137+
138+onVmRun :: RemoteTable -> String -> String -> IO ()
139+onVmRun rtable host port = do
140+ hSetBinaryMode stdin True
141+ proc <- BSL.getContents :: IO BSL.ByteString
142+ putStrLn $ "Got closure encoding of length " ++ show (BSL.length proc)
143+ mTransport <- createTransport host port defaultTCPParameters
144+ case mTransport of
145+ Left err -> throwIO err
146+ Right transport -> do
147+ node <- newLocalNode transport rtable
148+ runProcess node $ do
149+ liftIO $ putStrLn "Starting remote node"
150+ catch (join . unClosure . decode $ proc) (\e -> liftIO $ print (e :: SomeException))
151+
44152--------------------------------------------------------------------------------
45153-- Command line options --
46154--------------------------------------------------------------------------------
@@ -81,6 +189,7 @@ data Command =
81189 azureOptions :: AzureOptions
82190 , sshOptions :: SshOptions
83191 , target :: Target
192+ , port :: String
84193 }
85194 | OnVmCommand {
86195 onVmCommand :: OnVmCommand
@@ -167,6 +276,10 @@ runOnParser = RunOn
167276 <$> azureOptionsParser
168277 <*> sshOptionsParser
169278 <*> targetParser
279+ <*> strOption ( long "port"
280+ & metavar "PORT"
281+ & help "Port number of the CH instance"
282+ )
170283
171284onVmRunParser :: Parser OnVmCommand
172285onVmRunParser = OnVmRun
@@ -185,88 +298,3 @@ onVmCommandParser = OnVmCommand <$> subparser
185298 (progDesc "Run the executable"))
186299 )
187300
188−--------------------------------------------------------------------------------
189−-- Main --
190−--------------------------------------------------------------------------------
191−
192−main :: IO ()
193−main = do
194− _ <- SSH.initialize True
195− cmd <- execParser opts
196− case cmd of
197− List {} -> do
198− params <- azureParameters (azureOptions cmd) Nothing
199− backend <- initializeBackend params
200− css <- cloudServices backend
201− mapM_ print css
202− CopyTo {} -> do
203− params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
204− backend <- initializeBackend params
205− css <- cloudServices backend
206− forM_ (findTarget (target cmd) css) $ \vm -> do
207− putStr (vmName vm ++ ": ") >> hFlush stdout
208− copyToVM backend vm
209− putStrLn "Done"
210− CheckMD5 {} -> do
211− params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
212− backend <- initializeBackend params
213− css <- cloudServices backend
214− matches <- forM (findTarget (target cmd) css) $ \vm -> do
215− unless (status cmd) $ putStr (vmName vm ++ ": ") >> hFlush stdout
216− match <- checkMD5 backend vm
217− unless (status cmd) $ putStrLn $ if match then "OK" else "FAILED"
218− return match
219− if and matches
220− then exitSuccess
221− else exitFailure
222− RunOn {} -> do
223− params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
224− backend <- initializeBackend params
225− css <- cloudServices backend
226− forM_ (findTarget (target cmd) css) $ \vm -> do
227− putStr (vmName vm ++ ": ") >> hFlush stdout
228− runOnVM backend vm
229− putStrLn "Done"
230− OnVmCommand (vmCmd@OnVmRun {}) -> do
231− let rtable = initRemoteTable
232− onVmRun rtable (onVmIP vmCmd) (onVmPort vmCmd)
233− SSH.exit
234− where
235− opts = info (helper <*> commandParser)
236− ( fullDesc
237− & header "Cloud Haskell backend for Azure"
238− )
239−
240−findTarget :: Target -> [CloudService] -> [VirtualMachine]
241−findTarget (CloudService cs) css =
242− concatMap cloudServiceVMs . filter ((== cs) . cloudServiceName) $ css
243−findTarget (VirtualMachine virtualMachine) css =
244− [ vm | vm <- concatMap cloudServiceVMs css
245− , vmName vm == virtualMachine
246− ]
247−
248−azureParameters :: AzureOptions -> Maybe SshOptions -> IO AzureParameters
249−azureParameters opts Nothing =
250− defaultAzureParameters (subscriptionId opts)
251− (pathToCert opts)
252− (pathToKey opts)
253−azureParameters opts (Just sshOpts) = do
254− params <- defaultAzureParameters (subscriptionId opts)
255− (pathToCert opts)
256− (pathToKey opts)
257− return params {
258− azureSshUserName = remoteUser sshOpts
259− }
260−
261−onVmRun :: RemoteTable -> String -> String -> IO ()
262−onVmRun rtable host port = do
263− mTransport <- createTransport host port defaultTCPParameters
264− case mTransport of
265− Left err -> throwIO err
266− Right transport -> do
267− node <- newLocalNode transport rtable
268− runProcess node $ do
269− pid <- getSelfPid
270− liftIO . putStrLn $ "Azure controller has pid " ++ show pid
271−
272−