module Network.Azure.ServiceManagement
(
CloudService
, cloudServiceName
, cloudServiceVMs
, VirtualMachine
, vmName
, vmIpAddress
, vmInputEndpoints
, Endpoint
, endpointName
, endpointPort
, endpointVip
, vmSshEndpoint
, AzureSetup(..)
, azureSetup
, cloudServices
) where
import Prelude hiding (id, (.))
import Control.Category (id, (.))
import Control.Arrow (arr)
import Control.Monad (forM)
import Control.Applicative ((<$>), (<*>))
import Data.Maybe (listToMaybe)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Char8 as BSC (pack)
import Data.ByteString.Lazy.Char8 as BSLC (unpack)
import Data.Binary (Binary(get,put))
import Data.Binary.Put (runPut)
import Data.Binary.Get (Get, runGet)
import Network.TLS (PrivateKey(PrivRSA))
import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)
import Data.Certificate.X509 (X509, encodeCertificate, decodeCertificate)
import qualified Crypto.Types.PubKey.RSA as RSA (PrivateKey(..))
import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.IO.Class (liftIO)
import Control.Arrow.ArrowList (listA, arr2A)
import Text.PrettyPrint
( Doc
, text
, (<+>)
, ($$)
, vcat
, hang
, doubleQuotes
)
import Network.HTTP.Conduit
( parseUrl
, clientCertificates
, requestHeaders
, withManager
, Response(Response)
, httpLbs
, Manager
)
import Data.CaseInsensitive as CI (mk)
import Text.XML.HXT.Core
( runX
, readString
, withValidate
, no
, XmlTree
, IOSArrow
, ArrowXml
, getText
)
import Text.XML.HXT.XPath (getXPathTrees)
data HostedService = HostedService {
hostedServiceName :: String
}
data CloudService = CloudService {
cloudServiceName :: String
, cloudServiceVMs :: [VirtualMachine]
}
data VirtualMachine = VirtualMachine {
vmName :: String
, vmIpAddress :: String
, vmInputEndpoints :: [Endpoint]
}
data Endpoint = Endpoint {
endpointName :: String
, endpointPort :: String
, endpointVip :: String
}
instance Show HostedService where
show = show . ppHostedService
instance Show CloudService where
show = show . ppCloudService
instance Show VirtualMachine where
show = show . ppVirtualMachine
instance Show Endpoint where
show = show . ppEndpoint
ppHostedService :: HostedService -> Doc
ppHostedService = text . hostedServiceName
ppCloudService :: CloudService -> Doc
ppCloudService cs =
(text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs))
`hang2`
( text "VIRTUAL MACHINES"
`hang2`
(vcat . map ppVirtualMachine . cloudServiceVMs $ cs)
)
ppVirtualMachine :: VirtualMachine -> Doc
ppVirtualMachine vm =
(text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
`hang2`
( text "IP" <+> text (vmIpAddress vm)
$$ ( text "INPUT ENDPOINTS"
`hang2`
(vcat . map ppEndpoint . vmInputEndpoints $ vm)
)
)
ppEndpoint :: Endpoint -> Doc
ppEndpoint ep =
(text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
`hang2`
( text "Port" <+> text (endpointPort ep)
$$ text "VIP" <+> text (endpointVip ep)
)
hang2 :: Doc -> Doc -> Doc
hang2 d1 = hang d1 2
vmSshEndpoint :: VirtualMachine -> Maybe Endpoint
vmSshEndpoint vm = listToMaybe
[ ep
| ep <- vmInputEndpoints vm
, endpointName ep == "SSH"
]
data AzureSetup = AzureSetup
{
subscriptionId :: String
, certificate :: X509
, privateKey :: PrivateKey
, baseUrl :: String
}
encodePrivateKey :: PrivateKey -> ByteString
encodePrivateKey (PrivRSA pkey) = runPut $ do
put (RSA.private_size pkey)
put (RSA.private_n pkey)
put (RSA.private_d pkey)
put (RSA.private_p pkey)
put (RSA.private_q pkey)
put (RSA.private_dP pkey)
put (RSA.private_dQ pkey)
put (RSA.private_qinv pkey)
decodePrivateKey :: ByteString -> PrivateKey
decodePrivateKey = PrivRSA . runGet getPrivateKey
where
getPrivateKey :: Get RSA.PrivateKey
getPrivateKey =
RSA.PrivateKey <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get
instance Binary AzureSetup where
put (AzureSetup sid cert pkey url) = do
put sid
put (encodeCertificate cert)
put (encodePrivateKey pkey)
put url
get = do
sid <- get
Right cert <- decodeCertificate <$> get
pkey <- decodePrivateKey <$> get
url <- get
return $ AzureSetup sid cert pkey url
azureSetup :: String
-> String
-> String
-> IO AzureSetup
azureSetup sid certPath pkeyPath = do
cert <- fileReadCertificate certPath
pkey <- fileReadPrivateKey pkeyPath
return AzureSetup {
subscriptionId = sid
, certificate = cert
, privateKey = pkey
, baseUrl = "https://management.core.windows.net"
}
cloudServices :: AzureSetup -> IO [CloudService]
cloudServices setup = azureExecute setup $ \exec -> do
services <- exec hostedServicesRequest
forM services $ \service -> do
roles <- exec AzureRequest {
relativeUrl = "/services/hostedservices/" ++ hostedServiceName service
++ "?embed-detail=true"
, apiVersion = "2012-03-01"
, parser = proc xml -> do
role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml
name <- getText . getXPathTrees "/Role/RoleName/text()" -< role
roleInst <- arr2A getXPathTrees -< ("//RoleInstance[RoleName='" ++ name ++ "']", xml)
ip <- getText . getXPathTrees "/RoleInstance/IpAddress/text()" -< roleInst
endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role
id -< VirtualMachine name ip endpoints
}
return $ CloudService (hostedServiceName service) roles
hostedServicesRequest :: AzureRequest HostedService
hostedServicesRequest = AzureRequest
{ relativeUrl = "/services/hostedservices"
, apiVersion = "2012-03-01"
, parser = arr HostedService
. getText
. getXPathTrees "//ServiceName/text()"
}
parseEndpoint :: ArrowXml t => t XmlTree Endpoint
parseEndpoint = proc endpoint -> do
name <- getText . getXPathTrees "//Name/text()" -< endpoint
port <- getText . getXPathTrees "//Port/text()" -< endpoint
vip <- getText . getXPathTrees "//Vip/text()" -< endpoint
id -< Endpoint name port vip
data AzureRequest c = AzureRequest {
relativeUrl :: String
, apiVersion :: String
, parser :: IOSArrow XmlTree c
}
azureExecute :: AzureSetup -> ((forall b. AzureRequest b -> ResourceT IO [b]) -> ResourceT IO a) -> IO a
azureExecute setup f = withManager (\manager -> f (go manager))
where
go :: Manager -> forall b. AzureRequest b -> ResourceT IO [b]
go manager request = do
req <- parseUrl $ baseUrl setup
++ "/" ++ subscriptionId setup
++ "/" ++ relativeUrl request
let req' = req {
clientCertificates = [ (certificate setup, Just $ privateKey setup) ]
, requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack $ apiVersion request)
, (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")
]
}
Response _ _ _ lbs <- httpLbs req' manager
liftIO . runX $ proc _ -> do
xml <- readString [withValidate no] (BSLC.unpack lbs) -< ()
parser request -< xml