azure-service-api (empty) → 0.1.0.0
raw patch · 4 files changed
+395/−0 lines, 4 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, case-insensitive, certificate, crypto-pubkey-types, http-conduit, hxt, hxt-xpath, pretty, resourcet, tls, tls-extra, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- azure-service-api.cabal +44/−0
- src/Network/Azure/ServiceManagement.hs +319/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Edsko de Vries++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Edsko de Vries nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ azure-service-api.cabal view
@@ -0,0 +1,44 @@+-- Initial azure-service-api.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++Name: azure-service-api+Version: 0.1.0.0+Synopsis: Haskell bindings for the Microsoft Azure Service Management API+Description: At the moment, this module only provides minimal+ functionality, just enough to support the+ "distributed-process-azure" package (Azure backend for+ Cloud Haskell). However, the code is set up in such a way+ that adding additional functionality should be relatively+ straightforward; developers who wish to do will probably+ want to consult the Windows Azure Service Management REST+ API Reference+ (<http://msdn.microsoft.com/en-us/library/windowsazure/ee460799.aspx>). +Homepage: github.com/haskell-distributed/azure-service-api+License: BSD3+License-File: LICENSE+Author: Edsko de Vries+Maintainer: edsko@well-typed.com+Copyright: Well-Typed LLP+Category: Network+Build-Type: Simple+Cabal-Version: >=1.8++Library+ Exposed-Modules: Network.Azure.ServiceManagement + Build-Depends: base >= 4.5 && < 5,+ http-conduit >= 1.8.1 && < 1.9,+ tls >= 1.0 && < 1.1,+ tls-extra >= 0.5 && < 0.6,+ bytestring >= 0.9 && < 0.11,+ certificate >= 1.3 && < 1.4,+ case-insensitive >= 0.4 && < 0.5,+ hxt >= 9.2 && < 9.4,+ hxt-xpath >= 9.1 && < 9.2,+ pretty >= 1.1 && < 1.2,+ crypto-pubkey-types >= 0.1 && < 0.2, + binary >= 0.5 && < 0.7, + resourcet >= 0.4 && < 0.5,+ transformers >= 0.3 && < 0.4+ HS-Source-Dirs: src+ ghc-options: -Wall+ Extensions: RankNTypes
+ src/Network/Azure/ServiceManagement.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE Arrows #-}+module Network.Azure.ServiceManagement + ( -- * Data types+ CloudService+ , cloudServiceName+ , cloudServiceVMs+ , VirtualMachine+ , vmName+ , vmIpAddress+ , vmInputEndpoints+ , Endpoint+ , endpointName+ , endpointPort+ , endpointVip+ -- * Pure functions+ , vmSshEndpoint + -- * Setup+ , AzureSetup(..)+ , azureSetup+ -- * High-level API+ , 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 types --+--------------------------------------------------------------------------------++data HostedService = HostedService { + hostedServiceName :: String + }++-- | A cloud service is a bunch of virtual machines that are part of the same+-- network (i.e., can talk to each other directly using standard TCP +-- connections).+data CloudService = CloudService {+ -- | Name of the service.+ cloudServiceName :: String + -- | Virtual machines that are part of this cloud service.+ , cloudServiceVMs :: [VirtualMachine]+ }++-- | Virtual machine+data VirtualMachine = VirtualMachine { + -- | Name of the virtual machine.+ vmName :: String+ -- | The /internal/ IP address of the virtual machine (that is, the + -- IP address on the Cloud Service). For the globally accessible IP+ -- address see 'vmInputEndpoints'.+ , vmIpAddress :: String+ -- | Globally accessible endpoints to the virtual machine+ , vmInputEndpoints :: [Endpoint]+ }++-- | Globally accessible endpoint for a virtual machine+data Endpoint = Endpoint {+ -- | Name of the endpoint (typical example: @SSH@)+ endpointName :: String+ -- | Port number (typical examples are 22 or high numbered ports such as 53749) + , endpointPort :: String + -- | Virtual IP address (that is, globally accessible IP address).+ --+ -- This corresponds to the IP address associated with the Cloud Service+ -- (i.e., that would be returned by a DNS lookup for @name.cloudapp.net@, + -- where @name@ is the name of the Cloud Service).+ , endpointVip :: String+ }++--------------------------------------------------------------------------------+-- Pretty-printing --+--------------------------------------------------------------------------------++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++--------------------------------------------------------------------------------+-- Pure operations --+--------------------------------------------------------------------------------++-- | Find the endpoint with name @SSH@.+vmSshEndpoint :: VirtualMachine -> Maybe Endpoint+vmSshEndpoint vm = listToMaybe + [ ep+ | ep <- vmInputEndpoints vm+ , endpointName ep == "SSH"+ ]++--------------------------------------------------------------------------------+-- Setup --+--------------------------------------------------------------------------------++-- | Azure setup +--+-- The documentation of "distributed-process-azure" explains in detail how+-- to obtain the SSL client certificate and the private key for your Azure+-- account.+--+-- See also 'azureSetup'.+data AzureSetup = AzureSetup+ { -- | Azure subscription ID+ subscriptionId :: String+ -- | SSL client certificate+ , certificate :: X509+ -- | RSA private key+ , privateKey :: PrivateKey+ -- | Base URL (generally <https://management.core.windows.net>)+ , baseUrl :: String+ }++-- TODO: it's dubious to be transferring private keys, but we transfer them+-- over a secure connection and it can be argued that it's safer than actually+-- storing the private key on each remote server ++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++-- | Initialize Azure+azureSetup :: String -- ^ Subscription ID+ -> String -- ^ Path to certificate+ -> String -- ^ Path to private key+ -> 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"+ }++--------------------------------------------------------------------------------+-- High-level API --+--------------------------------------------------------------------------------++-- | Find available cloud services +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++--------------------------------------------------------------------------------+-- Low-level API --+--------------------------------------------------------------------------------++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) -< ()+ -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml+ parser request -< xml