@@ -1,27 +1,29 @@
11{-# LANGUAGE Arrows #-}
22module Network.Azure.ServiceManagement
33 ( -- * Data types
4− HostedService
4+ HostedService(..)
5+ , Role(..)
6+ , Endpoint(..)
57 -- * Setup
68 , AzureSetup(..)
79 , azureSetup
810 -- * High-level API
911 , hostedServices
10− , hostedServiceProperties
11− -- * Low-level API
12− , azureRequest
13− , azureRawRequest
12+ , virtualMachines
1413 ) where
1514
16−import Prelude hiding (id)
17−import Control.Category (id, (>>>))
15+import Prelude hiding (id, (.))
16+import Control.Category (id, (>>>), (.))
1817import Control.Arrow (arr)
19−import Data.ByteString.Lazy (ByteString)
18+import Control.Monad (forM)
2019import Data.ByteString.Char8 as BSC (pack)
2120import Data.ByteString.Lazy.Char8 as BSLC (unpack)
2221import Network.TLS (PrivateKey)
2322import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
2423import Data.Certificate.X509 (X509)
24+import Control.Monad.Trans.Resource (ResourceT)
25+import Control.Monad.IO.Class (liftIO)
26+import Control.Arrow.ArrowList (listA)
2527import Network.HTTP.Conduit
2628 ( parseUrl
2729 , clientCertificates
@@ -29,6 +31,7 @@ import Network.HTTP.Conduit
2931 , withManager
3032 , Response(Response)
3133 , httpLbs
34+ , Manager
3235 )
3336import Data.CaseInsensitive as CI (mk)
3437import Text.XML.HXT.Core
@@ -39,23 +42,34 @@ import Text.XML.HXT.Core
3942 , XmlTree
4043 , IOSArrow
4144 , ArrowXml
42− , deep
43− , hasName
4445 , getText
45− -- FOR DEBUGGING ONLY
46− , writeDocument
47− , withIndent
48− , yes
4946 )
47+import Text.XML.HXT.XPath (getXPathTrees)
5048
5149--------------------------------------------------------------------------------
5250-- Data types --
5351--------------------------------------------------------------------------------
5452
55−newtype HostedService = HostedService { unHostedService :: String }
53+data HostedService = HostedService {
54+ hostedServiceName :: String
55+ }
5656
5757instance 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
5973
6074--------------------------------------------------------------------------------
6175-- Setup --
@@ -66,7 +80,7 @@ data AzureSetup = AzureSetup
6680 { subscriptionId :: String
6781 , certificate :: X509
6882 , privateKey :: PrivateKey
69− , baseURL :: String
83+ , baseUrl :: String
7084 }
7185
7286-- | Initialize Azure
@@ -81,67 +95,73 @@ azureSetup sid certPath pkeyPath = do
8195 subscriptionId = sid
8296 , certificate = cert
8397 , privateKey = pkey
84− , baseURL = "https://management.core.windows.net"
98+ , baseUrl = "https://management.core.windows.net"
8599 }
86100
87101--------------------------------------------------------------------------------
88102-- High-level API --
89103--------------------------------------------------------------------------------
90104
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+
91122-- | Get list of available hosted services
92123hostedServices :: AzureSetup -> IO [HostedService]
93−hostedServices setup =
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"
124+hostedServices setup = azureExecute setup (\exec -> exec hostedServicesRequest)
110125
111−--------------------------------------------------------------------------------
112−-- Low-level API --
113−--------------------------------------------------------------------------------
126+hostedServicesRequest :: AzureRequest HostedService
127+hostedServicesRequest = AzureRequest
128+ { relativeUrl = "/services/hostedservices"
129+ , apiVersion = "2012-03-01"
130+ , parser = arr HostedService
131+ . getText
132+ . getXPathTrees "//ServiceName/text()"
133+ }
114134
115−-- | Execute an Azure request and parse the XML data
116−azureRequest :: AzureSetup
117− -> String
118− -> String
119− -> IOSArrow XmlTree c
120− -> IO [c]
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
135+parseEndpoint :: ArrowXml t => t XmlTree Endpoint
136+parseEndpoint = proc endpoint -> do
137+ name <- getText . getXPathTrees "//Name/text()" -< endpoint
138+ port <- getText . getXPathTrees "//Port/text()" -< endpoint
139+ vip <- getText . getXPathTrees "//Vip/text()" -< endpoint
140+ id -< Endpoint name port vip
141141
142142--------------------------------------------------------------------------------
143−-- XML convenience functions --
143+-- Low-level API --
144144--------------------------------------------------------------------------------
145145
146−getTextNode :: ArrowXml a => String -> a XmlTree String
147−getTextNode node = deep (hasName node) >>> deep getText
146+data AzureRequest c = AzureRequest {
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