@@ -1,297 +1,16 @@
11{-# LANGUAGE TemplateHaskell #-}
2−import Prelude hiding (catch)
3−import System.Environment (getArgs)
4−import System.Exit (exitSuccess, exitFailure)
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)
2+
143import Control.Monad.IO.Class (liftIO)
15−import Control.Arrow (returnA)
16−import Control.Exception (throwIO, SomeException)
17−import Control.Distributed.Process.Backend.Azure
18− ( AzureParameters(azureSshUserName)
19− , defaultAzureParameters
20− , initializeBackend
21− , cloudServices
22− , CloudService(cloudServiceName, cloudServiceVMs)
23− , VirtualMachine(vmName)
24− , Backend(copyToVM, checkMD5, runOnVM)
25− )
26−import qualified Network.SSH.Client.LibSSH2.Foreign as SSH
27− ( initialize
28− , exit
29− )
30−import Control.Applicative ((<$>), (<*>), (<|>), pure)
31−import Options.Applicative
32− ( Parser
33− , strOption
34− , long
35− , (&)
36− , metavar
37− , help
38− , subparser
39− , command
40− , info
41− , progDesc
42− , execParser
43− , helper
44− , fullDesc
45− , header
46− , switch
47− )
48−import Options.Applicative.Arrows (runA, asA)
49−import Control.Distributed.Process
50− ( getSelfPid
51− , RemoteTable
52− , Closure
53− , Process
54− , unClosure
55− , catch
56− )
4+import Control.Distributed.Process (Process)
575import Control.Distributed.Process.Closure (remotable, mkClosure)
58−import Control.Distributed.Process.Node (newLocalNode, runProcess, initRemoteTable)
59−import Network.Transport.TCP (createTransport, defaultTCPParameters)
6+import Control.Distributed.Process.Backend.Azure.GenericMain (genericMain)
607
618cprint :: String -> Process ()
629cprint = liftIO . putStrLn
6310
6411remotable ['cprint]
6512
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− mTransport <- createTransport host port defaultTCPParameters
143− case mTransport of
144− Left err -> throwIO err
145− Right transport -> do
146− node <- newLocalNode transport rtable
147− runProcess node $ join . unClosure . decode $ proc
148−
149−--------------------------------------------------------------------------------
150−-- Command line options --
151−--------------------------------------------------------------------------------
152−
153−data AzureOptions = AzureOptions {
154− subscriptionId :: String
155− , pathToCert :: FilePath
156− , pathToKey :: FilePath
157− }
158− deriving Show
159−
160−data SshOptions = SshOptions {
161− remoteUser :: String
162− }
163− deriving Show
164−
165−data Target =
166− VirtualMachine String
167− | CloudService String
168− deriving Show
169−
170−data Command =
171− List {
172− azureOptions :: AzureOptions
173− }
174− | CopyTo {
175− azureOptions :: AzureOptions
176− , sshOptions :: SshOptions
177− , target :: Target
178− }
179− | CheckMD5 {
180− azureOptions :: AzureOptions
181− , sshOptions :: SshOptions
182− , target :: Target
183− , status :: Bool
184− }
185− | RunOn {
186− azureOptions :: AzureOptions
187− , sshOptions :: SshOptions
188− , target :: Target
189− , port :: String
190− }
191− | OnVmCommand {
192− onVmCommand :: OnVmCommand
193− }
194− deriving Show
195−
196−data OnVmCommand =
197− OnVmRun {
198− onVmIP :: String
199− , onVmPort :: String
200− }
201− deriving Show
202−
203−azureOptionsParser :: Parser AzureOptions
204−azureOptionsParser = AzureOptions
205− <$> strOption ( long "subscription-id"
206− & metavar "SID"
207− & help "Azure subscription ID"
208− )
209− <*> strOption ( long "certificate"
210− & metavar "CERT"
211− & help "X509 certificate"
212− )
213− <*> strOption ( long "private"
214− & metavar "PRI"
215− & help "Private key in PKCS#1 format"
216− )
217−
218−sshOptionsParser :: Parser SshOptions
219−sshOptionsParser = SshOptions
220− <$> strOption ( long "user"
221− & metavar "USER"
222− & help "Remove SSH username"
223− )
224−
225−listParser :: Parser Command
226−listParser = List <$> azureOptionsParser
227−
228−copyToParser :: Parser Command
229−copyToParser = CopyTo
230− <$> azureOptionsParser
231− <*> sshOptionsParser
232− <*> targetParser
233−
234−targetParser :: Parser Target
235−targetParser =
236− ( VirtualMachine <$> strOption ( long "virtual-machine"
237− & metavar "VM"
238− & help "Virtual machine name"
239− )
240− )
241− <|>
242− ( CloudService <$> strOption ( long "cloud-service"
243− & metavar "CS"
244− & help "Cloud service name"
245− )
246− )
247−
248−checkMD5Parser :: Parser Command
249−checkMD5Parser = CheckMD5
250− <$> azureOptionsParser
251− <*> sshOptionsParser
252− <*> targetParser
253− <*> switch ( long "status"
254− & help "Don't output anything, status code shows success"
255− )
256−
257−commandParser :: Parser Command
258−commandParser = subparser
259− ( command "list" (info listParser
260− (progDesc "List Azure cloud services"))
261− & command "install" (info copyToParser
262− (progDesc "Install the executable"))
263− & command "md5" (info checkMD5Parser
264− (progDesc "Check if the remote and local MD5 hash match"))
265− & command "run" (info runOnParser
266− (progDesc "Run the executable"))
267− & command "onvm" (info onVmCommandParser
268− (progDesc "Commands used when running ON the vm (usually used internally only)"))
269− )
270−
271−runOnParser :: Parser Command
272−runOnParser = RunOn
273− <$> azureOptionsParser
274− <*> sshOptionsParser
275− <*> targetParser
276− <*> strOption ( long "port"
277− & metavar "PORT"
278− & help "Port number of the CH instance"
279− )
280−
281−onVmRunParser :: Parser OnVmCommand
282−onVmRunParser = OnVmRun
283− <$> strOption ( long "host"
284− & metavar "IP"
285− & help "IP address"
286− )
287− <*> strOption ( long "port"
288− & metavar "PORT"
289− & help "port number"
290− )
291−
292−onVmCommandParser :: Parser Command
293−onVmCommandParser = OnVmCommand <$> subparser
294− ( command "run" (info onVmRunParser
295− (progDesc "Run the executable"))
296− )
297−
13+main = genericMain __remoteTable $ \cmd ->
14+ case cmd of
15+ "hello" -> return $ $(mkClosure 'cprint) "Hi world!"
16+ _ -> error "unknown command"