git.iko.soy/distributed-process
on master help sign in
Add MD5 check
commitb3fe2fbebd0b870031173edb6f5c72986b40b36f authorEdsko de Vries <edsko@well-typed.com> dateTue 31 Jul 2012, 13:42 (14 years ago) parentb9b4aaa
3 files changed+108−22
compare with master
unifiedsplit
distributed-process-azure/distributed-process-azure.cabal+3−1 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+46−8 distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs+59−13
distributed-process-azure/distributed-process-azure.cabal+3−1
@@ -23,7 +23,9 @@ Library
2323 azure-service-api >= 0.1 && < 0.2,
2424 filepath >= 1.3 && < 1.4,
2525 executable-path >= 0.0.3 && < 0.1,
26− libssh2 >= 0.2 && < 0.3
26+ libssh2 >= 0.2 && < 0.3,
27+ pureMD5 >= 2.1 && < 2.2,
28+ bytestring >= 0.9 && < 0.11
2729 Exposed-modules: Control.Distributed.Process.Backend.Azure
2830 Extensions: ViewPatterns
2931 ghc-options: -Wall
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+46−8
@@ -12,6 +12,9 @@ module Control.Distributed.Process.Backend.Azure
1212import System.Environment (getEnv)
1313import System.FilePath ((</>), takeFileName)
1414import System.Environment.Executable (getExecutablePath)
15+import Data.Digest.Pure.MD5 (md5, MD5Digest)
16+import qualified Data.ByteString.Lazy as BSL (readFile)
17+import Control.Applicative ((<$>))
1518import Network.Azure.ServiceManagement
1619 ( CloudService(..)
1720 , VirtualMachine(..)
@@ -26,17 +29,25 @@ import qualified Network.SSH.Client.LibSSH2 as SSH
2629 ( withSSH2
2730 , execCommands
2831 , scpSendFile
32+ , withChannel
33+ , readAllChannel
2934 )
3035import qualified Network.SSH.Client.LibSSH2.Foreign as SSH
3136 ( initialize
3237 , exit
38+ , openChannelSession
39+ , retryIfNeeded
40+ , channelExecute
41+ , writeChannel
42+ , channelSendEOF
3343 )
3444
3545-- | Azure backend
3646data Backend = Backend {
3747 -- | Find virtual machines
3848 cloudServices :: IO [CloudService]
39− , startOnVM :: VirtualMachine -> IO ()
49+ , copyToVM :: VirtualMachine -> IO ()
50+ , checkMD5 :: VirtualMachine -> IO Bool
4051 }
4152
4253data AzureParameters = AzureParameters {
@@ -49,6 +60,7 @@ data AzureParameters = AzureParameters {
4960 , azureSshPassphrase :: String
5061 , azureSshKnownHosts :: FilePath
5162 , azureSshRemotePath :: FilePath
63+ , azureSshLocalPath :: FilePath
5264 }
5365
5466-- | Create default azure parameters
@@ -70,6 +82,7 @@ defaultAzureParameters sid x509 pkey = do
7082 , azureSshPassphrase = ""
7183 , azureSshKnownHosts = home </> ".ssh" </> "known_hosts"
7284 , azureSshRemotePath = takeFileName self
85+ , azureSshLocalPath = self
7386 }
7487
7588-- | Initialize the backend
@@ -80,13 +93,13 @@ initializeBackend params = do
8093 (azureAuthPrivateKey params)
8194 return Backend {
8295 cloudServices = Azure.cloudServices setup
83− , startOnVM = apiStartOnVM params
96+ , copyToVM = apiCopyToVM params
97+ , checkMD5 = apiCheckMD5 params
8498 }
8599
86100-- | Start a CH node on the given virtual machine
87−apiStartOnVM :: AzureParameters -> VirtualMachine -> IO ()
88−apiStartOnVM params (Azure.vmSshEndpoint -> Just ep) = do
89− self <- getExecutablePath
101+apiCopyToVM :: AzureParameters -> VirtualMachine -> IO ()
102+apiCopyToVM params (Azure.vmSshEndpoint -> Just ep) = do
90103 _ <- SSH.initialize True
91104 _ <- SSH.withSSH2 (azureSshKnownHosts params)
92105 (azureSshPublicKey params)
@@ -95,8 +108,33 @@ apiStartOnVM params (Azure.vmSshEndpoint -> Just ep) = do
95108 (azureSshUserName params)
96109 (endpointVip ep)
97110 (read $ endpointPort ep) $ \fd s -> do
98− SSH.scpSendFile fd s 0o700 self (azureSshRemotePath params)
111+ SSH.scpSendFile fd s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)
99112 -- SSH.execCommands fd s ["nohup /home/edsko/testservice >/dev/null 2>&1 &"]
100113 SSH.exit
101−apiStartOnVM _ _ =
102− error "startOnVM: No SSH endpoint"
114+apiCopyToVM _ _ =
115+ error "copyToVM: No SSH endpoint"
116+
117+apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool
118+apiCheckMD5 params (Azure.vmSshEndpoint -> Just ep) = do
119+ hash <- localHash params
120+ _ <- SSH.initialize True
121+ match <- SSH.withSSH2 (azureSshKnownHosts params)
122+ (azureSshPublicKey params)
123+ (azureSshPrivateKey params)
124+ (azureSshPassphrase params)
125+ (azureSshUserName params)
126+ (endpointVip ep)
127+ (read $ endpointPort ep) $ \fd s -> do
128+ (r, _) <- SSH.withChannel (SSH.openChannelSession s) id fd s $ \ch -> do
129+ SSH.retryIfNeeded fd s $ SSH.channelExecute ch ("md5sum -c --status")
130+ SSH.writeChannel ch $ show hash ++ " " ++ azureSshRemotePath params
131+ SSH.channelSendEOF ch
132+ SSH.readAllChannel fd ch
133+ return (r == 0)
134+ SSH.exit
135+ return match
136+apiCheckMD5 _ _ =
137+ error "checkMD5: No SSH endpoint"
138+
139+localHash :: AzureParameters -> IO MD5Digest
140+localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs+59−13
@@ -1,5 +1,7 @@
11{-# LANGUAGE Arrows #-}
22import System.Environment (getArgs)
3+import System.Exit (exitSuccess, exitFailure)
4+import Control.Monad (unless)
35import Control.Distributed.Process.Backend.Azure
46 ( AzureParameters(azureSshUserName)
57 , defaultAzureParameters
@@ -7,7 +9,7 @@ import Control.Distributed.Process.Backend.Azure
79 , cloudServices
810 , CloudService(cloudServiceVMs)
911 , VirtualMachine(vmName)
10− , startOnVM
12+ , Backend(copyToVM, checkMD5)
1113 )
1214import Control.Arrow (returnA)
1315import Control.Applicative ((<$>), (<*>))
@@ -26,6 +28,7 @@ import Options.Applicative
2628 , helper
2729 , fullDesc
2830 , header
31+ , switch
2932 )
3033import Options.Applicative.Arrows (runA, asA)
3134
@@ -46,8 +49,20 @@ data SshOptions = SshOptions {
4649 deriving Show
4750
4851data Command =
49− List AzureOptions
50− | Start AzureOptions SshOptions String
52+ List {
53+ azureOptions :: AzureOptions
54+ }
55+ | CopyTo {
56+ azureOptions :: AzureOptions
57+ , sshOptions :: SshOptions
58+ , virtualMachine :: String
59+ }
60+ | CheckMD5 {
61+ azureOptions :: AzureOptions
62+ , sshOptions :: SshOptions
63+ , virtualMachine :: String
64+ , status :: Bool
65+ }
5166 deriving Show
5267
5368azureOptionsParser :: Parser AzureOptions
@@ -75,8 +90,8 @@ sshOptionsParser = SshOptions
7590listParser :: Parser Command
7691listParser = List <$> azureOptionsParser
7792
78−startParser :: Parser Command
79−startParser = Start
93+copyToParser :: Parser Command
94+copyToParser = CopyTo
8095 <$> azureOptionsParser
8196 <*> sshOptionsParser
8297 <*> strOption ( long "vm"
@@ -84,12 +99,26 @@ startParser = Start
8499 & help "Virtual machine name"
85100 )
86101
102+checkMD5Parser :: Parser Command
103+checkMD5Parser = CheckMD5
104+ <$> azureOptionsParser
105+ <*> sshOptionsParser
106+ <*> strOption ( long "vm"
107+ & metavar "VM"
108+ & help "Virtual machine name"
109+ )
110+ <*> switch ( long "status"
111+ & help "Don't output anything, status code shows success"
112+ )
113+
87114commandParser :: Parser Command
88115commandParser = subparser
89116 ( command "list" (info listParser
90117 (progDesc "List Azure cloud services"))
91− & command "start" (info startParser
92− (progDesc "Start a new Cloud Haskell node"))
118+ & command "install" (info copyToParser
119+ (progDesc "Install the executable on a virtual machine"))
120+ & command "md5" (info checkMD5Parser
121+ (progDesc "Check if the remote and local MD5 hash match"))
93122 )
94123
95124--------------------------------------------------------------------------------
@@ -100,20 +129,37 @@ main :: IO ()
100129main = do
101130 cmd <- execParser opts
102131 case cmd of
103− List azureOpts -> do
104− params <- azureParameters azureOpts Nothing
132+ List {} -> do
133+ params <- azureParameters (azureOptions cmd) Nothing
105134 backend <- initializeBackend params
106135 css <- cloudServices backend
107136 mapM_ print css
108− Start azureOpts sshOpts name -> do
109− params <- azureParameters azureOpts (Just sshOpts)
137+ CopyTo {} -> do
138+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
110139 backend <- initializeBackend params
111140 css <- cloudServices backend
112141 let ch = head [ vm | vm <- concatMap cloudServiceVMs css
113− , vmName vm == name
142+ , vmName vm == virtualMachine cmd
114143 ]
115144 print ch
116− startOnVM backend ch
145+ copyToVM backend ch
146+ CheckMD5 {} -> do
147+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))
148+ backend <- initializeBackend params
149+ 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
117163 where
118164 opts = info (helper <*> commandParser)
119165 ( fullDesc