@@ -1,18 +1,19 @@
11{-# LANGUAGE Arrows #-}
22import System.Environment (getArgs)
33import System.Exit (exitSuccess, exitFailure)
4−import Control.Monad (unless)
4+import System.IO (hFlush, stdout)
5+import Control.Monad (unless, forM, forM_)
56import Control.Distributed.Process.Backend.Azure
67 ( AzureParameters(azureSshUserName)
78 , defaultAzureParameters
89 , initializeBackend
910 , cloudServices
10− , CloudService(cloudServiceVMs)
11+ , CloudService(cloudServiceName, cloudServiceVMs)
1112 , VirtualMachine(vmName)
1213 , Backend(copyToVM, checkMD5)
1314 )
1415import Control.Arrow (returnA)
15−import Control.Applicative ((<$>), (<*>))
16+import Control.Applicative ((<$>), (<*>), (<|>))
1617import Options.Applicative
1718 ( Parser
1819 , strOption
@@ -48,6 +49,11 @@ data SshOptions = SshOptions {
4849 }
4950 deriving Show
5051
52+data Target =
53+ VirtualMachine String
54+ | CloudService String
55+ deriving Show
56+
5157data Command =
5258 List {
5359 azureOptions :: AzureOptions
@@ -55,12 +61,12 @@ data Command =
5561 | CopyTo {
5662 azureOptions :: AzureOptions
5763 , sshOptions :: SshOptions
58− , virtualMachine :: String
64+ , target :: Target
5965 }
6066 | CheckMD5 {
6167 azureOptions :: AzureOptions
6268 , sshOptions :: SshOptions
63− , virtualMachine :: String
69+ , target :: Target
6470 , status :: Bool
6571 }
6672 deriving Show
@@ -94,19 +100,27 @@ copyToParser :: Parser Command
94100copyToParser = CopyTo
95101 <$> azureOptionsParser
96102 <*> sshOptionsParser
97− <*> strOption ( long "vm"
98− & metavar "VM"
99− & help "Virtual machine name"
100− )
103+ <*> targetParser
104+
105+targetParser :: Parser Target
106+targetParser =
107+ ( VirtualMachine <$> strOption ( long "virtual-machine"
108+ & metavar "VM"
109+ & help "Virtual machine name"
110+ )
111+ )
112+ <|>
113+ ( CloudService <$> strOption ( long "cloud-service"
114+ & metavar "CS"
115+ & help "Cloud service name"
116+ )
117+ )
101118
102119checkMD5Parser :: Parser Command
103120checkMD5Parser = CheckMD5
104121 <$> azureOptionsParser
105122 <*> sshOptionsParser
106− <*> strOption ( long "vm"
107− & metavar "VM"
108− & help "Virtual machine name"
109− )
123+ <*> targetParser
110124 <*> switch ( long "status"
111125 & help "Don't output anything, status code shows success"
112126 )
@@ -138,34 +152,36 @@ main = do
138152 params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
139153 backend <- initializeBackend params
140154 css <- cloudServices backend
141− let ch = head [ vm | vm <- concatMap cloudServiceVMs css
142− , vmName vm == virtualMachine cmd
143− ]
144− print ch
145− copyToVM backend ch
155+ forM_ (findTarget (target cmd) css) $ \vm -> do
156+ putStr (vmName vm ++ ": ") >> hFlush stdout
157+ copyToVM backend vm
158+ putStrLn "Done"
146159 CheckMD5 {} -> do
147160 params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
148161 backend <- initializeBackend params
149162 css <- cloudServices backend
150− let ch = head [ vm | vm <- concatMap cloudServiceVMs css
151− , vmName vm == virtualMachine cmd
152− ]
153− match <- checkMD5 backend ch
154− if match
155− then do
156− unless (status cmd) $
157− putStrLn "Local and remote MD5 hash match"
158− exitSuccess
159− else do
160− unless (status cmd) $
161− putStrLn "Local and remote MD5 hash do NOT match"
162− exitFailure
163+ matches <- forM (findTarget (target cmd) css) $ \vm -> do
164+ unless (status cmd) $ putStr (vmName vm ++ ": ") >> hFlush stdout
165+ match <- checkMD5 backend vm
166+ unless (status cmd) $ putStrLn $ if match then "OK" else "FAILED"
167+ return match
168+ if and matches
169+ then exitSuccess
170+ else exitFailure
163171 where
164172 opts = info (helper <*> commandParser)
165173 ( fullDesc
166174 & header "Cloud Haskell backend for Azure"
167175 )
168176
177+findTarget :: Target -> [CloudService] -> [VirtualMachine]
178+findTarget (CloudService cs) css =
179+ concatMap cloudServiceVMs . filter ((== cs) . cloudServiceName) $ css
180+findTarget (VirtualMachine virtualMachine) css =
181+ [ vm | vm <- concatMap cloudServiceVMs css
182+ , vmName vm == virtualMachine
183+ ]
184+
169185azureParameters :: AzureOptions -> Maybe SshOptions -> IO AzureParameters
170186azureParameters opts Nothing =
171187 defaultAzureParameters (subscriptionId opts)