diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/azure-service-api.cabal b/azure-service-api.cabal new file mode 100644 --- /dev/null +++ b/azure-service-api.cabal @@ -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 + (). +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 diff --git a/src/Network/Azure/ServiceManagement.hs b/src/Network/Azure/ServiceManagement.hs new file mode 100644 --- /dev/null +++ b/src/Network/Azure/ServiceManagement.hs @@ -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 ) + , 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