git.iko.soy/distributed-process
on master help sign in
Extend "install" and "md5" to cloud services
5585627Edsko de Vries
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs+47−31
compare with master
unifiedsplit
@@ -1,18 +1,19 @@
1{-# LANGUAGE Arrows #-}
1{-# LANGUAGE Arrows #-}
2import System.Environment (getArgs)
2import System.Environment (getArgs)
3import System.Exit (exitSuccess, exitFailure)
3import System.Exit (exitSuccess, exitFailure)
4+import System.IO (hFlush, stdout)
4−import Control.Monad (unless)
5+import Control.Monad (unless, forM, forM_)
5import Control.Distributed.Process.Backend.Azure
6import Control.Distributed.Process.Backend.Azure
6 ( AzureParameters(azureSshUserName)
7 ( AzureParameters(azureSshUserName)
7 , defaultAzureParameters
8 , defaultAzureParameters
8 , initializeBackend
9 , initializeBackend
9 , cloudServices
10 , cloudServices
10− , CloudService(cloudServiceVMs)
11+ , CloudService(cloudServiceName, cloudServiceVMs)
11 , VirtualMachine(vmName)
12 , VirtualMachine(vmName)
12 , Backend(copyToVM, checkMD5)
13 , Backend(copyToVM, checkMD5)
13 )
14 )
14import Control.Arrow (returnA)
15import Control.Arrow (returnA)
15−import Control.Applicative ((<$>), (<*>))
16+import Control.Applicative ((<$>), (<*>), (<|>))
16import Options.Applicative
17import Options.Applicative
17 ( Parser
18 ( Parser
18 , strOption
19 , strOption
@@ -48,6 +49,11 @@ data SshOptions = SshOptions {
48 }
49 }
49 deriving Show
50 deriving Show
50
51
52+data Target =
53+ VirtualMachine String
54+ | CloudService String
55+ deriving Show
56+
51data Command =
57data Command =
52 List {
58 List {
53 azureOptions :: AzureOptions
59 azureOptions :: AzureOptions
@@ -55,12 +61,12 @@ data Command =
55 | CopyTo {
61 | CopyTo {
56 azureOptions :: AzureOptions
62 azureOptions :: AzureOptions
57 , sshOptions :: SshOptions
63 , sshOptions :: SshOptions
58− , virtualMachine :: String
64+ , target :: Target
59 }
65 }
60 | CheckMD5 {
66 | CheckMD5 {
61 azureOptions :: AzureOptions
67 azureOptions :: AzureOptions
62 , sshOptions :: SshOptions
68 , sshOptions :: SshOptions
63− , virtualMachine :: String
69+ , target :: Target
64 , status :: Bool
70 , status :: Bool
65 }
71 }
66 deriving Show
72 deriving Show
@@ -94,19 +100,27 @@ copyToParser :: Parser Command
94copyToParser = CopyTo
100copyToParser = CopyTo
95 <$> azureOptionsParser
101 <$> azureOptionsParser
96 <*> sshOptionsParser
102 <*> sshOptionsParser
103+ <*> targetParser
104+
105+targetParser :: Parser Target
106+targetParser =
97− <*> strOption ( long "vm"
107+ ( VirtualMachine <$> strOption ( long "virtual-machine"
98− & metavar "VM"
108+ & metavar "VM"
99− & help "Virtual machine name"
109+ & help "Virtual machine name"
110+ )
111+ )
112+ <|>
113+ ( CloudService <$> strOption ( long "cloud-service"
114+ & metavar "CS"
115+ & help "Cloud service name"
116+ )
100− )
117+ )
101
118
102checkMD5Parser :: Parser Command
119checkMD5Parser :: Parser Command
103checkMD5Parser = CheckMD5
120checkMD5Parser = CheckMD5
104 <$> azureOptionsParser
121 <$> azureOptionsParser
105 <*> sshOptionsParser
122 <*> sshOptionsParser
106− <*> strOption ( long "vm"
123+ <*> targetParser
107− & metavar "VM"
108− & help "Virtual machine name"
109− )
110 <*> switch ( long "status"
124 <*> switch ( long "status"
111 & help "Don't output anything, status code shows success"
125 & help "Don't output anything, status code shows success"
112 )
126 )
@@ -138,34 +152,36 @@ main = do
138 params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
152 params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
139 backend <- initializeBackend params
153 backend <- initializeBackend params
140 css <- cloudServices backend
154 css <- cloudServices backend
141− let ch = head [ vm | vm <- concatMap cloudServiceVMs css
155+ forM_ (findTarget (target cmd) css) $ \vm -> do
142− , vmName vm == virtualMachine cmd
156+ putStr (vmName vm ++ ": ") >> hFlush stdout
143− ]
144− print ch
145− copyToVM backend ch
157+ copyToVM backend vm
158+ putStrLn "Done"
146 CheckMD5 {} -> do
159 CheckMD5 {} -> do
147 params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
160 params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
148 backend <- initializeBackend params
161 backend <- initializeBackend params
149 css <- cloudServices backend
162 css <- cloudServices backend
150− let ch = head [ vm | vm <- concatMap cloudServiceVMs css
163+ matches <- forM (findTarget (target cmd) css) $ \vm -> do
151− , vmName vm == virtualMachine cmd
164+ unless (status cmd) $ putStr (vmName vm ++ ": ") >> hFlush stdout
152− ]
153− match <- checkMD5 backend ch
165+ match <- checkMD5 backend vm
154− if match
155− then do
156− unless (status cmd) $
166+ unless (status cmd) $ putStrLn $ if match then "OK" else "FAILED"
157− putStrLn "Local and remote MD5 hash match"
167+ return match
168+ if and matches
158− exitSuccess
169+ then exitSuccess
159− else do
160− unless (status cmd) $
161− putStrLn "Local and remote MD5 hash do NOT match"
162− exitFailure
170+ else exitFailure
163 where
171 where
164 opts = info (helper <*> commandParser)
172 opts = info (helper <*> commandParser)
165 ( fullDesc
173 ( fullDesc
166 & header "Cloud Haskell backend for Azure"
174 & header "Cloud Haskell backend for Azure"
167 )
175 )
168
176
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+
169azureParameters :: AzureOptions -> Maybe SshOptions -> IO AzureParameters
185azureParameters :: AzureOptions -> Maybe SshOptions -> IO AzureParameters
170azureParameters opts Nothing =
186azureParameters opts Nothing =
171 defaultAzureParameters (subscriptionId opts)
187 defaultAzureParameters (subscriptionId opts)