git.iko.soy/distributed-process
on master help sign in
Use command line options parser
4b5f192Edsko de Vries
distributed-process-azure/distributed-process-azure.cabal+2−1
compare with master
unifiedsplit
@@ -35,4 +35,5 @@ Executable cloud-haskell-azure
35 utf8-string >= 0.3 && < 0.4,
35 utf8-string >= 0.3 && < 0.4,
36 libssh2 >= 0.2 && < 0.3,
36 libssh2 >= 0.2 && < 0.3,
37 filepath >= 1.3 && < 1.4,
37 filepath >= 1.3 && < 1.4,
38− distributed-process-azure >= 0.1 && < 0.2
38+ distributed-process-azure >= 0.1 && < 0.2,
39+ optparse-applicative >= 0.2 && < 0.3
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+5−2
@@ -25,6 +25,7 @@ import qualified Network.Azure.ServiceManagement as Azure
25import qualified Network.SSH.Client.LibSSH2 as SSH
25import qualified Network.SSH.Client.LibSSH2 as SSH
26 ( withSSH2
26 ( withSSH2
27 , execCommands
27 , execCommands
28+ , scpSendFile
28 )
29 )
29import qualified Network.SSH.Client.LibSSH2.Foreign as SSH
30import qualified Network.SSH.Client.LibSSH2.Foreign as SSH
30 ( initialize
31 ( initialize
@@ -68,7 +69,7 @@ defaultAzureParameters sid x509 pkey = do
68 , azureSshPrivateKey = home </> ".ssh" </> "id_rsa"
69 , azureSshPrivateKey = home </> ".ssh" </> "id_rsa"
69 , azureSshPassphrase = ""
70 , azureSshPassphrase = ""
70 , azureSshKnownHosts = home </> ".ssh" </> "known_hosts"
71 , azureSshKnownHosts = home </> ".ssh" </> "known_hosts"
71− , azureSshRemotePath = "/home" </> user </> takeFileName self
72+ , azureSshRemotePath = takeFileName self
72 }
73 }
73
74
74-- | Initialize the backend
75-- | Initialize the backend
@@ -85,6 +86,7 @@ initializeBackend params = do
85-- | Start a CH node on the given virtual machine
86-- | Start a CH node on the given virtual machine
86apiStartOnVM :: AzureParameters -> VirtualMachine -> IO ()
87apiStartOnVM :: AzureParameters -> VirtualMachine -> IO ()
87apiStartOnVM params (Azure.vmSshEndpoint -> Just ep) = do
88apiStartOnVM params (Azure.vmSshEndpoint -> Just ep) = do
89+ self <- getExecutablePath
88 _ <- SSH.initialize True
90 _ <- SSH.initialize True
89 _ <- SSH.withSSH2 (azureSshKnownHosts params)
91 _ <- SSH.withSSH2 (azureSshKnownHosts params)
90 (azureSshPublicKey params)
92 (azureSshPublicKey params)
@@ -93,7 +95,8 @@ apiStartOnVM params (Azure.vmSshEndpoint -> Just ep) = do
93 (azureSshUserName params)
95 (azureSshUserName params)
94 (endpointVip ep)
96 (endpointVip ep)
95 (read $ endpointPort ep) $ \fd s -> do
97 (read $ endpointPort ep) $ \fd s -> do
98+ SSH.scpSendFile fd s 0o700 self (azureSshRemotePath params)
96− SSH.execCommands fd s ["nohup /home/edsko/testservice >/dev/null 2>&1 &"]
99+ -- SSH.execCommands fd s ["nohup /home/edsko/testservice >/dev/null 2>&1 &"]
97 SSH.exit
100 SSH.exit
98apiStartOnVM _ _ =
101apiStartOnVM _ _ =
99 error "startOnVM: No SSH endpoint"
102 error "startOnVM: No SSH endpoint"
distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs+122−14
@@ -1,3 +1,4 @@
1+{-# LANGUAGE Arrows #-}
1import System.Environment (getArgs)
2import System.Environment (getArgs)
2import Control.Distributed.Process.Backend.Azure
3import Control.Distributed.Process.Backend.Azure
3 ( AzureParameters(azureSshUserName)
4 ( AzureParameters(azureSshUserName)
@@ -8,19 +9,126 @@ import Control.Distributed.Process.Backend.Azure
8 , VirtualMachine(vmName)
9 , VirtualMachine(vmName)
9 , startOnVM
10 , startOnVM
10 )
11 )
12+import Control.Arrow (returnA)
13+import Control.Applicative ((<$>), (<*>))
14+import Options.Applicative
15+ ( Parser
16+ , strOption
17+ , long
18+ , (&)
19+ , metavar
20+ , help
21+ , subparser
22+ , command
23+ , info
24+ , progDesc
25+ , execParser
26+ , helper
27+ , fullDesc
28+ , header
29+ )
30+import Options.Applicative.Arrows (runA, asA)
31+
32+--------------------------------------------------------------------------------
33+-- Command line options --
34+--------------------------------------------------------------------------------
35+
36+data AzureOptions = AzureOptions {
37+ subscriptionId :: String
38+ , pathToCert :: FilePath
39+ , pathToKey :: FilePath
40+ }
41+ deriving Show
42+
43+data SshOptions = SshOptions {
44+ remoteUser :: String
45+ }
46+ deriving Show
47+
48+data Command =
49+ List AzureOptions
50+ | Start AzureOptions SshOptions String
51+ deriving Show
52+
53+azureOptionsParser :: Parser AzureOptions
54+azureOptionsParser = AzureOptions
55+ <$> strOption ( long "subscription-id"
56+ & metavar "SID"
57+ & help "Azure subscription ID"
58+ )
59+ <*> strOption ( long "certificate"
60+ & metavar "CERT"
61+ & help "X509 certificate"
62+ )
63+ <*> strOption ( long "private"
64+ & metavar "PRI"
65+ & help "Private key in PKCS#1 format"
66+ )
67+
68+sshOptionsParser :: Parser SshOptions
69+sshOptionsParser = SshOptions
70+ <$> strOption ( long "user"
71+ & metavar "USER"
72+ & help "Remove SSH username"
73+ )
74+
75+listParser :: Parser Command
76+listParser = List <$> azureOptionsParser
77+
78+startParser :: Parser Command
79+startParser = Start
80+ <$> azureOptionsParser
81+ <*> sshOptionsParser
82+ <*> strOption ( long "vm"
83+ & metavar "VM"
84+ & help "Virtual machine name"
85+ )
86+
87+commandParser :: Parser Command
88+commandParser = subparser
89+ ( command "list" (info listParser
90+ (progDesc "List Azure cloud services"))
91+ & command "start" (info startParser
92+ (progDesc "Start a new Cloud Haskell node"))
93+ )
94+
95+--------------------------------------------------------------------------------
96+-- Main --
97+--------------------------------------------------------------------------------
11
98
12main :: IO ()
99main :: IO ()
13−main = do
100+main = do
14− [subscriptionId, pathToCert, pathToKey, user] <- getArgs
101+ cmd <- execParser opts
15− tryConnectToAzure subscriptionId pathToCert pathToKey user
102+ case cmd of
16−
103+ List azureOpts -> do
17−tryConnectToAzure :: String -> String -> String -> String -> IO ()
104+ params <- azureParameters azureOpts Nothing
18−tryConnectToAzure sid pathToCert pathToKey user = do
105+ backend <- initializeBackend params
19− params <- defaultAzureParameters sid pathToCert pathToKey
106+ css <- cloudServices backend
107+ print css
108+ Start azureOpts sshOpts name -> do
109+ params <- azureParameters azureOpts (Just sshOpts)
20− backend <- initializeBackend params { azureSshUserName = user }
110+ backend <- initializeBackend params
21− css <- cloudServices backend
111+ css <- cloudServices backend
22− let ch = head [ vm | vm <- concatMap cloudServiceVMs css
112+ let ch = head [ vm | vm <- concatMap cloudServiceVMs css
23− , vmName vm == "CloudHaskell"
113+ , vmName vm == name
24− ]
114+ ]
25− print ch
115+ print ch
26− startOnVM backend ch
116+ startOnVM backend ch
117+ where
118+ opts = info (helper <*> commandParser)
119+ ( fullDesc
120+ & header "Cloud Haskell backend for Azure"
121+ )
122+
123+azureParameters :: AzureOptions -> Maybe SshOptions -> IO AzureParameters
124+azureParameters opts Nothing =
125+ defaultAzureParameters (subscriptionId opts)
126+ (pathToCert opts)
127+ (pathToKey opts)
128+azureParameters opts (Just sshOpts) = do
129+ params <- defaultAzureParameters (subscriptionId opts)
130+ (pathToCert opts)
131+ (pathToKey opts)
132+ return params {
133+ azureSshUserName = remoteUser sshOpts
134+ }