git.iko.soy/distributed-process
on master help sign in
Get the list of VMs from Azure
c6f678fEdsko de Vries
azure-service-api/azure-service-api.cabal+5−1
compare with master
unifiedsplit
@@ -24,9 +24,13 @@ Library
24 bytestring >= 0.9 && < 1.0,
24 bytestring >= 0.9 && < 1.0,
25 certificate >= 1.2 && < 1.3,
25 certificate >= 1.2 && < 1.3,
26 case-insensitive >= 0.4 && < 0.5,
26 case-insensitive >= 0.4 && < 0.5,
27− hxt >= 9.2 && < 9.3
27+ hxt >= 9.2 && < 9.3,
28+ resourcet,
29+ transformers,
30+ hxt-xpath
28 HS-Source-Dirs: src
31 HS-Source-Dirs: src
29 ghc-options: -Wall
32 ghc-options: -Wall
33+ Extensions: RankNTypes
30
34
31Executable hs-azure-service-api
35Executable hs-azure-service-api
32 Main-Is: src/Network/Azure/ServiceManagement/CommandLine.hs
36 Main-Is: src/Network/Azure/ServiceManagement/CommandLine.hs
azure-service-api/src/Network/Azure/ServiceManagement.hs+87−67
@@ -1,27 +1,29 @@
1{-# LANGUAGE Arrows #-}
1{-# LANGUAGE Arrows #-}
2module Network.Azure.ServiceManagement
2module Network.Azure.ServiceManagement
3 ( -- * Data types
3 ( -- * Data types
4− HostedService
4+ HostedService(..)
5+ , Role(..)
6+ , Endpoint(..)
5 -- * Setup
7 -- * Setup
6 , AzureSetup(..)
8 , AzureSetup(..)
7 , azureSetup
9 , azureSetup
8 -- * High-level API
10 -- * High-level API
9 , hostedServices
11 , hostedServices
10− , hostedServiceProperties
12+ , virtualMachines
11− -- * Low-level API
12− , azureRequest
13− , azureRawRequest
14 ) where
13 ) where
15
14
16−import Prelude hiding (id)
15+import Prelude hiding (id, (.))
17−import Control.Category (id, (>>>))
16+import Control.Category (id, (>>>), (.))
18import Control.Arrow (arr)
17import Control.Arrow (arr)
19−import Data.ByteString.Lazy (ByteString)
18+import Control.Monad (forM)
20import Data.ByteString.Char8 as BSC (pack)
19import Data.ByteString.Char8 as BSC (pack)
21import Data.ByteString.Lazy.Char8 as BSLC (unpack)
20import Data.ByteString.Lazy.Char8 as BSLC (unpack)
22import Network.TLS (PrivateKey)
21import Network.TLS (PrivateKey)
23import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
22import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
24import Data.Certificate.X509 (X509)
23import Data.Certificate.X509 (X509)
24+import Control.Monad.Trans.Resource (ResourceT)
25+import Control.Monad.IO.Class (liftIO)
26+import Control.Arrow.ArrowList (listA)
25import Network.HTTP.Conduit
27import Network.HTTP.Conduit
26 ( parseUrl
28 ( parseUrl
27 , clientCertificates
29 , clientCertificates
@@ -29,6 +31,7 @@ import Network.HTTP.Conduit
29 , withManager
31 , withManager
30 , Response(Response)
32 , Response(Response)
31 , httpLbs
33 , httpLbs
34+ , Manager
32 )
35 )
33import Data.CaseInsensitive as CI (mk)
36import Data.CaseInsensitive as CI (mk)
34import Text.XML.HXT.Core
37import Text.XML.HXT.Core
@@ -39,23 +42,34 @@ import Text.XML.HXT.Core
39 , XmlTree
42 , XmlTree
40 , IOSArrow
43 , IOSArrow
41 , ArrowXml
44 , ArrowXml
42− , deep
43− , hasName
44 , getText
45 , getText
45− -- FOR DEBUGGING ONLY
46− , writeDocument
47− , withIndent
48− , yes
49 )
46 )
47+import Text.XML.HXT.XPath (getXPathTrees)
50
48
51--------------------------------------------------------------------------------
49--------------------------------------------------------------------------------
52-- Data types --
50-- Data types --
53--------------------------------------------------------------------------------
51--------------------------------------------------------------------------------
54
52
55−newtype HostedService = HostedService { unHostedService :: String }
53+data HostedService = HostedService {
54+ hostedServiceName :: String
55+ }
56
56
57instance Show HostedService where
57instance Show HostedService where
58− show = unHostedService
58+ show = hostedServiceName
59+
60+data Role = Role {
61+ roleName :: String
62+ }
63+
64+instance Show Role where
65+ show = roleName
66+
67+data Endpoint = Endpoint {
68+ endpointName :: String
69+ , endpointPort :: String
70+ , endpointVip :: String
71+ }
72+ deriving Show
59
73
60--------------------------------------------------------------------------------
74--------------------------------------------------------------------------------
61-- Setup --
75-- Setup --
@@ -66,7 +80,7 @@ data AzureSetup = AzureSetup
66 { subscriptionId :: String
80 { subscriptionId :: String
67 , certificate :: X509
81 , certificate :: X509
68 , privateKey :: PrivateKey
82 , privateKey :: PrivateKey
69− , baseURL :: String
83+ , baseUrl :: String
70 }
84 }
71
85
72-- | Initialize Azure
86-- | Initialize Azure
@@ -81,67 +95,73 @@ azureSetup sid certPath pkeyPath = do
81 subscriptionId = sid
95 subscriptionId = sid
82 , certificate = cert
96 , certificate = cert
83 , privateKey = pkey
97 , privateKey = pkey
84− , baseURL = "https://management.core.windows.net"
98+ , baseUrl = "https://management.core.windows.net"
85 }
99 }
86
100
87--------------------------------------------------------------------------------
101--------------------------------------------------------------------------------
88-- High-level API --
102-- High-level API --
89--------------------------------------------------------------------------------
103--------------------------------------------------------------------------------
90
104
105+-- | Get a list of virtual machines
106+virtualMachines :: AzureSetup -> IO [(HostedService, [(Role, [Endpoint])])]
107+virtualMachines setup = azureExecute setup $ \exec -> do
108+ services <- exec hostedServicesRequest
109+ forM services $ \service -> do
110+ roles <- exec AzureRequest {
111+ relativeUrl = "/services/hostedservices/" ++ hostedServiceName service
112+ ++ "?embed-detail=true"
113+ , apiVersion = "2012-03-01"
114+ , parser = proc xml -> do
115+ role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml
116+ name <- getText . getXPathTrees "/Role/RoleName/text()" -< role
117+ endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role
118+ id -< (Role name, endpoints)
119+ }
120+ return (service, roles)
121+
91-- | Get list of available hosted services
122-- | Get list of available hosted services
92hostedServices :: AzureSetup -> IO [HostedService]
123hostedServices :: AzureSetup -> IO [HostedService]
93−hostedServices setup =
124+hostedServices setup = azureExecute setup (\exec -> exec hostedServicesRequest)
94− azureRequest setup subURL "2012-03-01" $ proc xml -> do
95− writeDocument [withIndent yes] "hostedservices.xml" -< xml
96− hostedService <- deep (hasName "HostedService") -< xml
97− name <- getTextNode "ServiceName" -< hostedService
98− arr HostedService -< name
99− where
100− subURL = "/services/hostedservices"
101−
102−-- | Get properties of the given hosted service
103−hostedServiceProperties :: AzureSetup -> HostedService -> IO [()]
104−hostedServiceProperties setup (HostedService service) = do
105− azureRequest setup subURL "2012-03-01" $ proc xml -> do
106− writeDocument [withIndent yes] "properties.xml" -< xml
107− id -< ()
108− where
109− subURL = "/services/hostedservices/" ++ service ++ "?embed-detail=true"
110
125
111−--------------------------------------------------------------------------------
126+hostedServicesRequest :: AzureRequest HostedService
112−-- Low-level API --
127+hostedServicesRequest = AzureRequest
113−--------------------------------------------------------------------------------
128+ { relativeUrl = "/services/hostedservices"
129+ , apiVersion = "2012-03-01"
130+ , parser = arr HostedService
131+ . getText
132+ . getXPathTrees "//ServiceName/text()"
133+ }
114
134
115−-- | Execute an Azure request and parse the XML data
135+parseEndpoint :: ArrowXml t => t XmlTree Endpoint
116−azureRequest :: AzureSetup
136+parseEndpoint = proc endpoint -> do
117− -> String
137+ name <- getText . getXPathTrees "//Name/text()" -< endpoint
118− -> String
138+ port <- getText . getXPathTrees "//Port/text()" -< endpoint
119− -> IOSArrow XmlTree c
139+ vip <- getText . getXPathTrees "//Vip/text()" -< endpoint
120− -> IO [c]
140+ id -< Endpoint name port vip
121−azureRequest setup subURL version f = do
122− raw <- azureRawRequest setup subURL version
123− runX $ readString [withValidate no] (BSLC.unpack raw) >>> f
124−
125−-- | Execute an Azure request and return the raw data
126−azureRawRequest :: AzureSetup
127− -> String -- ^ Relative path
128− -> String -- ^ Version
129− -> IO ByteString
130−azureRawRequest setup subURL version = do
131− req <- parseUrl $ baseURL setup ++ "/" ++ subscriptionId setup ++ "/" ++ subURL
132− withManager $ \manager -> do
133− let req' = req {
134− clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
135− , requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack version)
136− , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
137− ]
138− }
139− Response _ _ _ lbs <- httpLbs req' manager
140− return lbs
141
141
142--------------------------------------------------------------------------------
142--------------------------------------------------------------------------------
143−-- XML convenience functions --
143+-- Low-level API --
144--------------------------------------------------------------------------------
144--------------------------------------------------------------------------------
145
145
146−getTextNode :: ArrowXml a => String -> a XmlTree String
146+data AzureRequest c = AzureRequest {
147−getTextNode node = deep (hasName node) >>> deep getText
147+ relativeUrl :: String
148+ , apiVersion :: String
149+ , parser :: IOSArrow XmlTree c
150+ }
151+
152+azureExecute :: AzureSetup -> ((forall b. AzureRequest b -> ResourceT IO [b]) -> ResourceT IO a) -> IO a
153+azureExecute setup f = withManager (\manager -> f (go manager))
154+ where
155+ go :: Manager -> forall b. AzureRequest b -> ResourceT IO [b]
156+ go manager request = do
157+ req <- parseUrl $ baseUrl setup
158+ ++ "/" ++ subscriptionId setup
159+ ++ "/" ++ relativeUrl request
160+ let req' = req {
161+ clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
162+ , requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack $ apiVersion request)
163+ , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
164+ ]
165+ }
166+ Response _ _ _ lbs <- httpLbs req' manager
167+ liftIO . runX $ readString [withValidate no] (BSLC.unpack lbs) >>> parser request
azure-service-api/src/Network/Azure/ServiceManagement/CommandLine.hs+4−10
@@ -1,5 +1,4 @@
1-- Base
1-- Base
2−import Control.Monad (forM_)
3import System.Environment (getArgs, getEnv)
2import System.Environment (getArgs, getEnv)
4import System.FilePath ((</>))
3import System.FilePath ((</>))
5import System.Posix.Types (Fd)
4import System.Posix.Types (Fd)
@@ -7,8 +6,7 @@ import System.Posix.Types (Fd)
7-- SSL
6-- SSL
8import Network.Azure.ServiceManagement
7import Network.Azure.ServiceManagement
9 ( azureSetup
8 ( azureSetup
10− , hostedServices
9+ , virtualMachines
11− , hostedServiceProperties
12 )
10 )
13
11
14-- SSH
12-- SSH
@@ -62,15 +60,11 @@ ssh login host port actions = do
62 exit
60 exit
63
61
64--------------------------------------------------------------------------------
62--------------------------------------------------------------------------------
65−-- Taken from tls-debug/src/SimpleClient.hs --
63+-- Azure tests --
66--------------------------------------------------------------------------------
64--------------------------------------------------------------------------------
67
65
68tryConnectToAzure :: String -> String -> String -> IO ()
66tryConnectToAzure :: String -> String -> String -> IO ()
69tryConnectToAzure sid pathToCert pathToKey = do
67tryConnectToAzure sid pathToCert pathToKey = do
70 setup <- azureSetup sid pathToCert pathToKey
68 setup <- azureSetup sid pathToCert pathToKey
71− services <- hostedServices setup
69+ vms <- virtualMachines setup
72− mapM_ print services
70+ mapM_ print vms
73− forM_ services $ \service -> do
74− props <- hostedServiceProperties setup service
75− print props
76−