@@ -1,13 +1,20 @@
1+{-# LANGUAGE Arrows #-}
12module Network.Azure.ServiceManagement
2− ( -- * Submitting requests
3− azureRequest
4− -- * Re-export functionality from TLS
5− , fileReadCertificate
6− , fileReadPrivateKey
3+ ( -- * Setup
4+ AzureSetup(..)
5+ , azureSetup
6+ -- * High-level API
7+ , hostedServices
8+ -- * Low-level API
9+ , azureRequest
10+ , azureRawRequest
711 ) where
812
13+import Prelude hiding (id)
14+import Control.Category (id, (>>>))
915import Data.ByteString.Lazy (ByteString)
1016import Data.ByteString.Char8 as BSC (pack)
17+import Data.ByteString.Lazy.Char8 as BSLC (unpack)
1118import Network.TLS (PrivateKey)
1219import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
1320import Data.Certificate.X509 (X509)
@@ -20,22 +27,93 @@ import Network.HTTP.Conduit
2027 , httpLbs
2128 )
2229import Data.CaseInsensitive as CI (mk)
30+import Text.XML.HXT.Core
31+ ( runX
32+ , readString
33+ , withValidate
34+ , no
35+ , XmlTree
36+ , IOSArrow
37+ , XNode
38+ , ArrowXml
39+ , deep
40+ , hasName
41+ , getText
42+ )
43+
44+--------------------------------------------------------------------------------
45+-- Setup --
46+--------------------------------------------------------------------------------
47+
48+-- | Azure setup
49+data AzureSetup = AzureSetup
50+ { subscriptionId :: String
51+ , certificate :: X509
52+ , privateKey :: PrivateKey
53+ , baseURL :: String
54+ }
55+
56+-- | Initialize Azure
57+azureSetup :: String -- ^ Subscription ID
58+ -> String -- ^ Path to certificate
59+ -> String -- ^ Path to private key
60+ -> IO AzureSetup
61+azureSetup sid certPath pkeyPath = do
62+ cert <- fileReadCertificate certPath
63+ pkey <- fileReadPrivateKey pkeyPath
64+ return AzureSetup {
65+ subscriptionId = sid
66+ , certificate = cert
67+ , privateKey = pkey
68+ , baseURL = "https://management.core.windows.net"
69+ }
70+
71+--------------------------------------------------------------------------------
72+-- High-level API --
73+--------------------------------------------------------------------------------
2374
24−-- ^ Execute an Azure request
25−azureRequest :: String -- ^ Subscription ID
26− -> X509 -- ^ X509 certificate
27− -> PrivateKey -- ^ Private key
28− -> String -- ^ Relative path
29− -> String -- ^ Version
30− -> IO ByteString
31−azureRequest sid cert pkey subURL version = do
32− req <- parseUrl $ "https://management.core.windows.net/" ++ sid++ subURL
75+hostedServices :: AzureSetup -> IO [(String, String)]
76+hostedServices setup =
77+ azureRequest setup "/services/hostedservices" "2012-03-01" $ proc xml -> do
78+ hostedService <- deep (hasName "HostedService") -< xml
79+ url <- getTextNode "Url" -< hostedService
80+ serviceName <- getTextNode "ServiceName" -< hostedService
81+ id -< (url, serviceName)
82+
83+--------------------------------------------------------------------------------
84+-- Low-level API --
85+--------------------------------------------------------------------------------
86+
87+-- | Execute an Azure request and parse the XML data
88+azureRequest :: AzureSetup
89+ -> String
90+ -> String
91+ -> IOSArrow XmlTree c
92+ -> IO [c]
93+azureRequest setup subURL version f = do
94+ raw <- azureRawRequest setup subURL version
95+ runX $ readString [withValidate no] (BSLC.unpack raw) >>> f
96+
97+-- | Execute an Azure request and return the raw data
98+azureRawRequest :: AzureSetup
99+ -> String -- ^ Relative path
100+ -> String -- ^ Version
101+ -> IO ByteString
102+azureRawRequest setup subURL version = do
103+ req <- parseUrl $ baseURL setup ++ "/" ++ subscriptionId setup ++ "/" ++ subURL
33104 withManager $ \manager -> do
34105 let req' = req {
35− clientCertificates = [ (cert, Just pkey) ]
106+ clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
36107 , requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack version)
37108 , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
38109 ]
39110 }
40111 Response _ _ _ lbs <- httpLbs req' manager
41112 return lbs
113+
114+--------------------------------------------------------------------------------
115+-- XML convenience functions --
116+--------------------------------------------------------------------------------
117+
118+getTextNode :: ArrowXml a => String -> a XmlTree String
119+getTextNode node = deep (hasName node) >>> deep getText