@@ -1,3 +1,4 @@
1+{-# LANGUAGE Arrows #-}
12import System.Environment (getArgs)
23import Control.Distributed.Process.Backend.Azure
34 ( AzureParameters(azureSshUserName)
@@ -8,19 +9,126 @@ import Control.Distributed.Process.Backend.Azure
89 , VirtualMachine(vmName)
910 , startOnVM
1011 )
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+--------------------------------------------------------------------------------
1198
1299main :: IO ()
13−main = do
14− [subscriptionId, pathToCert, pathToKey, user] <- getArgs
15− tryConnectToAzure subscriptionId pathToCert pathToKey user
16−
17−tryConnectToAzure :: String -> String -> String -> String -> IO ()
18−tryConnectToAzure sid pathToCert pathToKey user = do
19− params <- defaultAzureParameters sid pathToCert pathToKey
20− backend <- initializeBackend params { azureSshUserName = user }
21− css <- cloudServices backend
22− let ch = head [ vm | vm <- concatMap cloudServiceVMs css
23− , vmName vm == "CloudHaskell"
24− ]
25− print ch
26− startOnVM backend ch
100+main = do
101+ cmd <- execParser opts
102+ case cmd of
103+ List azureOpts -> do
104+ params <- azureParameters azureOpts Nothing
105+ backend <- initializeBackend params
106+ css <- cloudServices backend
107+ print css
108+ Start azureOpts sshOpts name -> do
109+ params <- azureParameters azureOpts (Just sshOpts)
110+ backend <- initializeBackend params
111+ css <- cloudServices backend
112+ let ch = head [ vm | vm <- concatMap cloudServiceVMs css
113+ , vmName vm == name
114+ ]
115+ print 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+ }