@@ -16,7 +16,7 @@ module Network.Azure.ServiceManagement
1616 ) where
1717
1818import Prelude hiding (id, (.))
19−import Control.Category (id, (>>>), (.))
19+import Control.Category (id, (.))
2020import Control.Arrow (arr)
2121import Control.Monad (forM)
2222import Data.Maybe (listToMaybe)
@@ -27,7 +27,7 @@ import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
2727import Data.Certificate.X509 (X509)
2828import Control.Monad.Trans.Resource (ResourceT)
2929import Control.Monad.IO.Class (liftIO)
30−import Control.Arrow.ArrowList (listA)
30+import Control.Arrow.ArrowList (listA, arr2A)
3131import Text.PrettyPrint
3232 ( Doc
3333 , text
@@ -56,7 +56,11 @@ import Text.XML.HXT.Core
5656 , IOSArrow
5757 , ArrowXml
5858 , getText
59+-- , writeDocumentToString
60+-- , withIndent
61+-- , yes
5962 )
63+-- import Control.Arrow.ArrowIO (arrIO)
6064import Text.XML.HXT.XPath (getXPathTrees)
6165
6266--------------------------------------------------------------------------------
@@ -74,6 +78,7 @@ data CloudService = CloudService {
7478
7579data VirtualMachine = VirtualMachine {
7680 vmName :: String
81+ , vmIpAddress :: String
7782 , vmInputEndpoints :: [Endpoint]
7883 }
7984
@@ -115,9 +120,11 @@ ppVirtualMachine :: VirtualMachine -> Doc
115120ppVirtualMachine vm =
116121 (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
117122 `hang2`
118− ( text "INPUT ENDPOINTS"
119− `hang2`
120− (vcat . map ppEndpoint . vmInputEndpoints $ vm)
123+ ( text "IP" <+> text (vmIpAddress vm)
124+ $$ ( text "INPUT ENDPOINTS"
125+ `hang2`
126+ (vcat . map ppEndpoint . vmInputEndpoints $ vm)
127+ )
121128 )
122129
123130ppEndpoint :: Endpoint -> Doc
@@ -125,11 +132,11 @@ ppEndpoint ep =
125132 (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
126133 `hang2`
127134 ( text "Port" <+> text (endpointPort ep)
128− $$ text "IP" <+> text (endpointVip ep)
135+ $$ text "VIP" <+> text (endpointVip ep)
129136 )
130137
131138hang2 :: Doc -> Doc -> Doc
132−hang2 d1 d2 = hang d1 2 d2
139+hang2 d1 = hang d1 2
133140
134141--------------------------------------------------------------------------------
135142-- Pure operations --
@@ -185,8 +192,10 @@ cloudServices setup = azureExecute setup $ \exec -> do
185192 , parser = proc xml -> do
186193 role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml
187194 name <- getText . getXPathTrees "/Role/RoleName/text()" -< role
195+ roleInst <- arr2A getXPathTrees -< ("//RoleInstance[RoleName='" ++ name ++ "']", xml)
196+ ip <- getText . getXPathTrees "/RoleInstance/IpAddress/text()" -< roleInst
188197 endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role
189− id -< VirtualMachine name endpoints
198+ id -< VirtualMachine name ip endpoints
190199 }
191200 return $ CloudService (hostedServiceName service) roles
192201
@@ -235,4 +244,7 @@ azureExecute setup f = withManager (\manager -> f (go manager))
235244 ]
236245 }
237246 Response _ _ _ lbs <- httpLbs req' manager
238− liftIO . runX $ readString [withValidate no] (BSLC.unpack lbs) >>> parser request
247+ liftIO . runX $ proc _ -> do
248+ xml <- readString [withValidate no] (BSLC.unpack lbs) -< ()
249+ -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml
250+ parser request -< xml