git.iko.soy/distributed-process
on master help sign in
Find out internal IP address of VMs
1a462b2Edsko de Vries
azure-service-api/src/Network/Azure/ServiceManagement.hs+21−9
compare with master
unifiedsplit
@@ -16,7 +16,7 @@ module Network.Azure.ServiceManagement
16 ) where
16 ) where
17
17
18import Prelude hiding (id, (.))
18import Prelude hiding (id, (.))
19−import Control.Category (id, (>>>), (.))
19+import Control.Category (id, (.))
20import Control.Arrow (arr)
20import Control.Arrow (arr)
21import Control.Monad (forM)
21import Control.Monad (forM)
22import Data.Maybe (listToMaybe)
22import Data.Maybe (listToMaybe)
@@ -27,7 +27,7 @@ import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
27import Data.Certificate.X509 (X509)
27import Data.Certificate.X509 (X509)
28import Control.Monad.Trans.Resource (ResourceT)
28import Control.Monad.Trans.Resource (ResourceT)
29import Control.Monad.IO.Class (liftIO)
29import Control.Monad.IO.Class (liftIO)
30−import Control.Arrow.ArrowList (listA)
30+import Control.Arrow.ArrowList (listA, arr2A)
31import Text.PrettyPrint
31import Text.PrettyPrint
32 ( Doc
32 ( Doc
33 , text
33 , text
@@ -56,7 +56,11 @@ import Text.XML.HXT.Core
56 , IOSArrow
56 , IOSArrow
57 , ArrowXml
57 , ArrowXml
58 , getText
58 , getText
59+-- , writeDocumentToString
60+-- , withIndent
61+-- , yes
59 )
62 )
63+-- import Control.Arrow.ArrowIO (arrIO)
60import Text.XML.HXT.XPath (getXPathTrees)
64import Text.XML.HXT.XPath (getXPathTrees)
61
65
62--------------------------------------------------------------------------------
66--------------------------------------------------------------------------------
@@ -74,6 +78,7 @@ data CloudService = CloudService {
74
78
75data VirtualMachine = VirtualMachine {
79data VirtualMachine = VirtualMachine {
76 vmName :: String
80 vmName :: String
81+ , vmIpAddress :: String
77 , vmInputEndpoints :: [Endpoint]
82 , vmInputEndpoints :: [Endpoint]
78 }
83 }
79
84
@@ -115,9 +120,11 @@ ppVirtualMachine :: VirtualMachine -> Doc
115ppVirtualMachine vm =
120ppVirtualMachine vm =
116 (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
121 (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
117 `hang2`
122 `hang2`
123+ ( text "IP" <+> text (vmIpAddress vm)
118− ( text "INPUT ENDPOINTS"
124+ $$ ( text "INPUT ENDPOINTS"
119− `hang2`
125+ `hang2`
120− (vcat . map ppEndpoint . vmInputEndpoints $ vm)
126+ (vcat . map ppEndpoint . vmInputEndpoints $ vm)
127+ )
121 )
128 )
122
129
123ppEndpoint :: Endpoint -> Doc
130ppEndpoint :: Endpoint -> Doc
@@ -125,11 +132,11 @@ ppEndpoint ep =
125 (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
132 (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
126 `hang2`
133 `hang2`
127 ( text "Port" <+> text (endpointPort ep)
134 ( text "Port" <+> text (endpointPort ep)
128− $$ text "IP" <+> text (endpointVip ep)
135+ $$ text "VIP" <+> text (endpointVip ep)
129 )
136 )
130
137
131hang2 :: Doc -> Doc -> Doc
138hang2 :: Doc -> Doc -> Doc
132−hang2 d1 d2 = hang d1 2 d2
139+hang2 d1 = hang d1 2
133
140
134--------------------------------------------------------------------------------
141--------------------------------------------------------------------------------
135-- Pure operations --
142-- Pure operations --
@@ -185,8 +192,10 @@ cloudServices setup = azureExecute setup $ \exec -> do
185 , parser = proc xml -> do
192 , parser = proc xml -> do
186 role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml
193 role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml
187 name <- getText . getXPathTrees "/Role/RoleName/text()" -< role
194 name <- getText . getXPathTrees "/Role/RoleName/text()" -< role
195+ roleInst <- arr2A getXPathTrees -< ("//RoleInstance[RoleName='" ++ name ++ "']", xml)
196+ ip <- getText . getXPathTrees "/RoleInstance/IpAddress/text()" -< roleInst
188 endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role
197 endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role
189− id -< VirtualMachine name endpoints
198+ id -< VirtualMachine name ip endpoints
190 }
199 }
191 return $ CloudService (hostedServiceName service) roles
200 return $ CloudService (hostedServiceName service) roles
192
201
@@ -235,4 +244,7 @@ azureExecute setup f = withManager (\manager -> f (go manager))
235 ]
244 ]
236 }
245 }
237 Response _ _ _ lbs <- httpLbs req' manager
246 Response _ _ _ lbs <- httpLbs req' manager
247+ liftIO . runX $ proc _ -> do
238− liftIO . runX $ readString [withValidate no] (BSLC.unpack lbs) >>> parser request
248+ xml <- readString [withValidate no] (BSLC.unpack lbs) -< ()
249+ -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml
250+ parser request -< xml