diff --git a/Aws/Route53.hs b/Aws/Route53.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53.hs @@ -0,0 +1,12 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +module Aws.Route53 +( module Aws.Route53.Commands +, module Aws.Route53.Core +) +where + +import Aws.Route53.Commands +import Aws.Route53.Core diff --git a/Aws/Route53/Commands.hs b/Aws/Route53/Commands.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands.hs @@ -0,0 +1,30 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +module Aws.Route53.Commands +( -- * Actions on Hosted Zones + module Aws.Route53.Commands.CreateHostedZone +, module Aws.Route53.Commands.GetHostedZone +, module Aws.Route53.Commands.DeleteHostedZone +, module Aws.Route53.Commands.ListHostedZones + + -- * Actions on Resource Record Sets +, module Aws.Route53.Commands.ChangeResourceRecordSets +, module Aws.Route53.Commands.ListResourceRecordSets +, module Aws.Route53.Commands.GetChange + + -- * Other Commands +, module Aws.Route53.Commands.GetDate +) +where + +import Aws.Route53.Commands.CreateHostedZone +import Aws.Route53.Commands.GetHostedZone +import Aws.Route53.Commands.DeleteHostedZone +import Aws.Route53.Commands.ListHostedZones +import Aws.Route53.Commands.ChangeResourceRecordSets +import Aws.Route53.Commands.ListResourceRecordSets +import Aws.Route53.Commands.GetChange +import Aws.Route53.Commands.GetDate + diff --git a/Aws/Route53/Commands/ChangeResourceRecordSets.hs b/Aws/Route53/Commands/ChangeResourceRecordSets.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/ChangeResourceRecordSets.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE QuasiQuotes #-} +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | POST ChangeResourceRecordSetrs +-- +-- Creates, changes, or deletes resource records sets. +-- +-- +-- +module Aws.Route53.Commands.ChangeResourceRecordSets where + +import Aws.Route53.Core +import Aws.Core +import Text.Hamlet.XML (xml) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Map (empty) +import qualified Text.XML as XML +import qualified Data.ByteString as B + +data ACTION = CREATE | DELETE | UPSERT + deriving (Show) + +-- TODO enforce constrains either via type or dynamically on creation or usage +data ChangeResourceRecordSets = ChangeResourceRecordSets + { crrHostedZoneId :: HostedZoneId + , crrComment :: Maybe T.Text + , crrsChanges :: [(ACTION, ResourceRecordSet)] + } deriving (Show) + +data ChangeResourceRecordSetsResponse = ChangeResourceRecordSetsResponse + { crrsrChangeInfo :: ChangeInfo + } deriving (Show) + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery ChangeResourceRecordSets where + type ServiceConfiguration ChangeResourceRecordSets = Route53Configuration + signQuery ChangeResourceRecordSets{..} = route53SignQuery method resource query body + where + method = Post + resource = (T.encodeUtf8 . qualifiedIdText) crrHostedZoneId `B.append` "/rrset" + query = [] + body = Just $ XML.Element "ChangeResourceRecordSetsRequest" empty + [xml| + + $maybe c <- crrComment + #{c} + + $forall change <- crrsChanges + + #{T.pack (show (fst change))} + ^{[XML.NodeElement (toXml (snd change))]} + |] + +instance ResponseConsumer r ChangeResourceRecordSetsResponse where + type ResponseMetadata ChangeResourceRecordSetsResponse = Route53Metadata + + responseConsumer _ = route53ResponseConsumer parse + where + parse cursor = do + route53CheckResponseType () "ChangeResourceRecordSetsResponse" cursor + changeInfo <- r53Parse cursor + return $ ChangeResourceRecordSetsResponse changeInfo + +instance Transaction ChangeResourceRecordSets ChangeResourceRecordSetsResponse + diff --git a/Aws/Route53/Commands/CreateHostedZone.hs b/Aws/Route53/Commands/CreateHostedZone.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/CreateHostedZone.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE QuasiQuotes #-} +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | POST CreateHostedZone +-- +-- Create a new Route53 hosted zone. +-- +-- +-- +module Aws.Route53.Commands.CreateHostedZone where + +import Aws.Core +import Aws.Route53.Core +import Text.Hamlet.XML (xml) +import qualified Data.Text as T +import Data.Map (empty) +import qualified Text.XML as XML + +data CreateHostedZone = CreateHostedZone + { chzName :: Domain + , chzCallerReference :: T.Text + , chzComment :: T.Text + } deriving (Show) + +data CreateHostedZoneResponse = CreateHostedZoneResponse + { chzrHostedZone :: HostedZone + , chzrChangeInfo :: ChangeInfo + , chzrDelegationSet :: DelegationSet + } deriving (Show) + +createHostedZone :: Domain -> T.Text -> T.Text -> CreateHostedZone +createHostedZone name callerReference comment = CreateHostedZone name callerReference comment + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery CreateHostedZone where + type ServiceConfiguration CreateHostedZone = Route53Configuration + signQuery CreateHostedZone{..} = route53SignQuery method resource query body + where + method = Post + resource = "/hostedzone" + query = [] + body = Just $ XML.Element "CreateHostedZoneRequest" empty + [xml| + #{dText chzName} + #{chzCallerReference} + + #{chzComment} + |] + +instance ResponseConsumer r CreateHostedZoneResponse where + type ResponseMetadata CreateHostedZoneResponse = Route53Metadata + + responseConsumer _ = route53ResponseConsumer parse + where + parse cursor = do + route53CheckResponseType () "CreateHostedZoneResponse" cursor + zone <- r53Parse cursor + changeInfo <- r53Parse cursor + delegationSet <- r53Parse cursor + return $ CreateHostedZoneResponse zone changeInfo delegationSet + +instance Transaction CreateHostedZone CreateHostedZoneResponse + diff --git a/Aws/Route53/Commands/DeleteHostedZone.hs b/Aws/Route53/Commands/DeleteHostedZone.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/DeleteHostedZone.hs @@ -0,0 +1,57 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | DELETE DeleteHostedZone +-- +-- Delete a particular Route53 hosted zone identified through its 'hostedZoneId'. +-- The HostedZoneId is obtained in the response to 'Aws.Route53.Commands.CreateHostedZone' +-- or 'Aws.Route53.Commands.ListHostedZones' +-- +-- Note that the hosted zone can be delete only after deleting all resource records other than +-- the default SOA record and the NS records. +-- +-- +-- +module Aws.Route53.Commands.DeleteHostedZone where + +import Aws.Core +import Aws.Route53.Core +import qualified Data.Text.Encoding as T + +data DeleteHostedZone = DeleteHostedZone + { dhzHostedZoneId :: HostedZoneId + } deriving (Show) + +data DeleteHostedZoneResponse = DeleteHostedZoneResponse + { dhzrChangeInfo :: ChangeInfo + } deriving (Show) + +deleteHostedZone :: HostedZoneId -> DeleteHostedZone +deleteHostedZone hostedZoneId = DeleteHostedZone hostedZoneId + +-- Delete add convenience methods: +-- * Delete non-empty hosted zone + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery DeleteHostedZone where + type ServiceConfiguration DeleteHostedZone = Route53Configuration + signQuery DeleteHostedZone{..} = route53SignQuery method resource query body + where + method = Delete + resource = T.encodeUtf8 . qualifiedIdText $ dhzHostedZoneId + query = [] + body = Nothing + +instance ResponseConsumer r DeleteHostedZoneResponse where + type ResponseMetadata DeleteHostedZoneResponse = Route53Metadata + + responseConsumer _ = route53ResponseConsumer parse + where + parse cursor = do + route53CheckResponseType () "DeleteHostedZoneResponse" cursor + changeInfo <- r53Parse cursor + return $ DeleteHostedZoneResponse changeInfo + +instance Transaction DeleteHostedZone DeleteHostedZoneResponse + diff --git a/Aws/Route53/Commands/GetChange.hs b/Aws/Route53/Commands/GetChange.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/GetChange.hs @@ -0,0 +1,49 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | GET GetChange +-- +-- Returns the current status of change batch request. +-- +-- +-- +module Aws.Route53.Commands.GetChange where + +import Aws.Core +import Aws.Route53.Core +import qualified Data.Text.Encoding as T + +data GetChange = GetChange + { changeId :: ChangeId + } deriving (Show) + +data GetChangeResponse = GetChangeResponse + { gcrChangeInfo :: ChangeInfo + } deriving (Show) + +getChange :: ChangeId -> GetChange +getChange changeId = GetChange changeId + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery GetChange where + type ServiceConfiguration GetChange = Route53Configuration + signQuery GetChange{..} = route53SignQuery method resource query body + where + method = Get + resource = T.encodeUtf8 . qualifiedIdText $ changeId + query = [] + body = Nothing + +instance ResponseConsumer r GetChangeResponse where + type ResponseMetadata GetChangeResponse = Route53Metadata + + responseConsumer _ = route53ResponseConsumer parse + where + parse cursor = do + route53CheckResponseType () "GetChangeResponse" cursor + changeInfo <- r53Parse cursor + return $ GetChangeResponse changeInfo + +instance Transaction GetChange GetChangeResponse + diff --git a/Aws/Route53/Commands/GetDate.hs b/Aws/Route53/Commands/GetDate.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/GetDate.hs @@ -0,0 +1,64 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | GET GetDate +-- +-- Receive current date string from Route53 service that can be used as date string for +-- authenticating REST requests to Route53. +-- +-- +-- +module Aws.Route53.Commands.GetDate where + +import Aws.Core +import Aws.Route53.Core +import Data.Maybe +import Data.Time (UTCTime) +import Data.Time.Format (parseTime) +import System.Locale (defaultTimeLocale) +import Data.ByteString.Char8 (unpack) +import qualified Network.HTTP.Conduit as HTTP +import qualified Network.HTTP.Types as HTTP + +data GetDate = GetDate deriving (Show) + +newtype GetDateResponse = GetDateResponse { date :: UTCTime } deriving (Show) + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery GetDate where + type ServiceConfiguration GetDate = Route53Configuration + signQuery GetDate info sd = SignedQuery + { sqMethod = Get + , sqProtocol = route53Protocol info + , sqHost = route53Endpoint info + , sqPort = route53Port info + , sqPath = "/date/" + , sqQuery = [] + , sqDate = Just $ signatureTime sd + , sqAuthorization = Nothing + , sqContentType = Nothing + , sqContentMd5 = Nothing + , sqAmzHeaders = [] + , sqOtherHeaders = [] + , sqBody = Nothing + , sqStringToSign = "" + } + +instance ResponseConsumer r GetDateResponse where + type ResponseMetadata GetDateResponse = () + responseConsumer _ _ resp = return $ GetDateResponse date + where + -- TODO add proper error handling + date = fromJust $ do + str <- findHeaderValue (HTTP.responseHeaders resp) HTTP.hDate + -- FIXME: this is probably to restrictive. We should support full rfc1123 + parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" (unpack str) + +getDate :: GetDate +getDate = GetDate + +instance Transaction GetDate GetDateResponse + +instance Loggable () where + toLogText _ = "" diff --git a/Aws/Route53/Commands/GetHostedZone.hs b/Aws/Route53/Commands/GetHostedZone.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/GetHostedZone.hs @@ -0,0 +1,52 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | GET GetHostedZone +-- +-- Get a particular Route53 hosted zone identified through its 'hostedZoneId'. +-- The HostedZoneId is obtained in the response to 'Aws.Route53.Commands.CreateHostedZone' +-- or 'Aws.Route53.Commands.ListHostedZones' +-- +-- +-- +module Aws.Route53.Commands.GetHostedZone where + +import Aws.Core +import Aws.Route53.Core +import qualified Data.Text.Encoding as T + +data GetHostedZone = GetHostedZone + { hostedZoneId :: HostedZoneId + } deriving (Show) + +data GetHostedZoneResponse = GetHostedZoneResponse + { ghzrHostedZone :: HostedZone + , ghzrDelegationSet :: DelegationSet + } deriving (Show) + +getHostedZone :: HostedZoneId -> GetHostedZone +getHostedZone hostedZoneId = GetHostedZone hostedZoneId + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery GetHostedZone where + type ServiceConfiguration GetHostedZone = Route53Configuration + signQuery GetHostedZone{..} = route53SignQuery method resource query Nothing + where + method = Get + resource = T.encodeUtf8 . qualifiedIdText $ hostedZoneId + query = [] + +instance ResponseConsumer r GetHostedZoneResponse where + type ResponseMetadata GetHostedZoneResponse = Route53Metadata + + responseConsumer _ = route53ResponseConsumer parse + where + parse cursor = do + route53CheckResponseType () "GetHostedZoneResponse" cursor + zone <- r53Parse cursor + delegationSet <- r53Parse cursor + return $ GetHostedZoneResponse zone delegationSet + +instance Transaction GetHostedZone GetHostedZoneResponse + diff --git a/Aws/Route53/Commands/ListHostedZones.hs b/Aws/Route53/Commands/ListHostedZones.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/ListHostedZones.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TupleSections #-} +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | GET ListHostedZones +-- +-- List all Route53 hosted zones of the user, optionally paginated. +-- +-- +-- +module Aws.Route53.Commands.ListHostedZones where + +import Aws.Core +import Aws.Route53.Core +import Data.Maybe +import Control.Applicative ((<$>), (<$)) +import Text.XML.Cursor (($//)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +data ListHostedZones = ListHostedZones + { lhzMaxNumberOfItems :: Maybe Int + , lhzNextToken :: Maybe T.Text + } deriving (Show) + +data ListHostedZonesResponse = ListHostedZonesResponse + { lhzrHostedZones :: HostedZones + , lhzrNextToken :: Maybe T.Text + } deriving (Show) + +listHostedZones :: ListHostedZones +listHostedZones = ListHostedZones { lhzMaxNumberOfItems = Nothing, lhzNextToken = Nothing } + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery ListHostedZones where + type ServiceConfiguration ListHostedZones = Route53Configuration + signQuery ListHostedZones{..} = route53SignQuery method resource query Nothing + where + method = Get + resource = "/hostedzone" + query = catMaybes + [ ("MaxItems",) . T.encodeUtf8 . T.pack . show <$> lhzMaxNumberOfItems + , ("NextToken",) . T.encodeUtf8 <$> lhzNextToken + ] + +instance ResponseConsumer r ListHostedZonesResponse where + type ResponseMetadata ListHostedZonesResponse = Route53Metadata + + responseConsumer _ = route53ResponseConsumer parser + where + parser cursor = do + route53CheckResponseType () "ListHostedZonesResponse" cursor + zones <- r53Parse cursor + let nextToken = listToMaybe $ cursor $// elContent "NextMarker" + return $ ListHostedZonesResponse zones nextToken + +instance Transaction ListHostedZones ListHostedZonesResponse + +instance IteratedTransaction ListHostedZones ListHostedZonesResponse where + nextIteratedRequest req ListHostedZonesResponse{ lhzrNextToken = nt } = req { lhzNextToken = nt } <$ nt + --combineIteratedResponse (ListHostedZonesResponse z0 _) (ListHostedZonesResponse z1 nt) = ListHostedZonesResponse (z0 ++ z1) nt + diff --git a/Aws/Route53/Commands/ListResourceRecordSets.hs b/Aws/Route53/Commands/ListResourceRecordSets.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Commands/ListResourceRecordSets.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TupleSections #-} +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | GET ListResourceRecordSets +-- +-- Lists the resource record sets for a Route53 hosted zone. The hosted zone is identified by +-- the hostedZoneId which is retrieved in the response to 'Aws.Route53.Commands.ListHostedZones' +-- or 'Aws.Route53.Commands.CreateHostedZone'. +-- +-- +-- +-- NOTE: the parameter 'identifier' is required for weighted and latency resource record sets. This is +-- not enforced by the type. +-- +module Aws.Route53.Commands.ListResourceRecordSets where + +import Aws.Core +import Aws.Route53.Core +import Data.Maybe (catMaybes, listToMaybe) +import Control.Applicative ((<$>)) +import Control.Monad (guard) +import Text.XML.Cursor (($//), (&|), ($/)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Char8 as B + +data ListResourceRecordSets = ListResourceRecordSets + { lrrsHostedZoneId :: HostedZoneId + , lrrsName :: Maybe Domain + , lrrsRecordType :: Maybe RecordType + , lrrsIdentifier :: Maybe T.Text -- ^ must be present for weighted or latency resource record sets. TODO introduce newtype wrapper + , lrrsMaxItems :: Maybe Int -- ^ maximum effective value is 100 + } deriving (Show) + +-- | A most general 'ListResourceRecordSets' query +listResourceRecordSets :: HostedZoneId -> ListResourceRecordSets +listResourceRecordSets hostedZoneId = ListResourceRecordSets hostedZoneId Nothing Nothing Nothing Nothing + +data ListResourceRecordSetsResponse = ListResourceRecordSetsResponse + { lrrsrResourceRecordSets :: ResourceRecordSets + , lrrsrIsTruncated :: Bool + , lrrsrMaxItems :: Maybe Int -- ^ The maxitems value from the request + , lrrsrNextRecordName :: Maybe Domain -- ^ TODO check constraint + , lrrsrNextRecordType :: Maybe RecordType -- ^ TODO check constraint + , lrrsrNextRecordIdentifier :: Maybe T.Text -- ^ TODO check constraint + } deriving (Show) + +-- | ServiceConfiguration: 'Route53Configuration' +instance SignQuery ListResourceRecordSets where + type ServiceConfiguration ListResourceRecordSets = Route53Configuration + signQuery ListResourceRecordSets{..} = route53SignQuery method resource query body + where + method = Get + body = Nothing + resource = (T.encodeUtf8 . qualifiedIdText) lrrsHostedZoneId `B.append` "/rrset" + query = catMaybes [ ("name",) . T.encodeUtf8 . dText <$> lrrsName + , ("type",) . B.pack . typeToString <$> lrrsRecordType + , ("identifier",) . T.encodeUtf8 <$> lrrsIdentifier + , ("maxitems",) . B.pack . show <$> lrrsMaxItems + ] + +instance ResponseConsumer r ListResourceRecordSetsResponse where + type ResponseMetadata ListResourceRecordSetsResponse = Route53Metadata + + responseConsumer _ = route53ResponseConsumer parser + where + parser cursor = do + route53CheckResponseType () "ListResourceRecordSetsResponse" cursor + resourceRecordSets <- r53Parse cursor + isTruncated <- force "Missing IsTruncated element" $ cursor $/ elCont "IsTruncated" &| ("true"==) + maxItems <- listToMaybe <$> (sequence $ cursor $/ elCont "MaxItems" &| readInt) + let nextRecordName = listToMaybe $ cursor $// elContent "NextRecordName" &| Domain + let nextRecordType = listToMaybe $ cursor $// elCont "NextRecordType" &| read + let nextRecordIdentifier = listToMaybe $ cursor $// elContent "NextRecordIdentifier" + return $ ListResourceRecordSetsResponse resourceRecordSets isTruncated maxItems nextRecordName nextRecordType nextRecordIdentifier + +instance Transaction ListResourceRecordSets ListResourceRecordSetsResponse + +instance IteratedTransaction ListResourceRecordSets ListResourceRecordSetsResponse where + nextIteratedRequest ListResourceRecordSets{..} ListResourceRecordSetsResponse{..} = do + guard lrrsrIsTruncated + return $ ListResourceRecordSets lrrsHostedZoneId + lrrsrNextRecordName + lrrsrNextRecordType + lrrsrNextRecordIdentifier + lrrsrMaxItems +{- combineIteratedResponse a b = ListResourceRecordSetsResponse + { lrrsrResourceRecordSets = lrrsrResourceRecordSets a ++ lrrsrResourceRecordSets b + , lrrsrIsTruncated = lrrsrIsTruncated b + , lrrsrNextRecordName = lrrsrNextRecordName b + , lrrsrNextRecordType = lrrsrNextRecordType b + , lrrsrNextRecordIdentifier = lrrsrNextRecordIdentifier b + , lrrsrMaxItems = lrrsrMaxItems b + }-} + diff --git a/Aws/Route53/Core.hs b/Aws/Route53/Core.hs new file mode 100644 --- /dev/null +++ b/Aws/Route53/Core.hs @@ -0,0 +1,565 @@ +{-# LANGUAGE QuasiQuotes, FlexibleContexts, TypeSynonymInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +module Aws.Route53.Core +( -- * Configuration + Route53Configuration(..) +, route53EndpointUsClassic +, route53 + + -- * Error +, Route53Error(..) + + -- * Metadata +, Route53Metadata(..) + + -- * Query +, route53SignQuery + + -- * Response +, route53ResponseConsumer +, route53CheckResponseType + + -- * Model + + -- ** DNS +, RecordType(..) +, typeToString + + -- ** Hosted Zone +, HostedZone (..) +, HostedZones +, Domain(..) +, HostedZoneId(..) + + -- ** Delegation Set +, DelegationSet(..) +, Nameserver +, Nameservers +, dsNameservers + + -- ** Resource Record Set +, REGION(..) +, ResourceRecordSets +, ResourceRecordSet(..) +, ResourceRecords +, ResourceRecord(..) +, AliasTarget(..) + + -- ** Change Info +, ChangeInfo(..) +, ChangeInfoStatus(..) +, ChangeId(..) + + -- * Parser Utilities +, Route53Parseable(..) +, Route53XmlSerializable(..) +, Route53Id(..) + + -- * HTTP Utilites + -- | This functions extend 'Network.HTTP.Types' +, findHeader +, findHeaderValue +, hRequestId +) where + +import Aws.Core +import Data.IORef +import Data.Monoid +import Data.String +import Data.Typeable +import Control.Monad (MonadPlus, mzero, mplus, liftM) +import Control.Monad.Trans.Resource (MonadThrow(..)) +import Data.List (find) +import Data.Map (insert, empty) +import Data.Maybe (fromMaybe, listToMaybe, fromJust) +import Data.Text (Text, unpack) +import Data.Text.Encoding (decodeUtf8) +import Data.Time (UTCTime) +import Data.Time.Format (parseTime) +import System.Locale (defaultTimeLocale) +import Text.Hamlet.XML (xml) +import Text.XML (elementAttributes) +import Text.XML.Cursor (($/), ($//), (&|), ($.//), laxElement) +import qualified Control.Exception as C +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Conduit as HTTP +import qualified Network.HTTP.Types as HTTP +import qualified Text.XML as XML +import qualified Text.XML.Cursor as Cu + +-- -------------------------------------------------------------------------- -- +-- Configuration + +data Route53Configuration qt = Route53Configuration + { route53Protocol :: Protocol + , route53Endpoint :: B.ByteString + , route53Port :: Int + , route53ApiVersion :: B.ByteString + , route53XmlNamespace :: T.Text + + } deriving (Show) + +instance DefaultServiceConfiguration (Route53Configuration NormalQuery) where + defServiceConfig = route53 + debugServiceConfig = route53 + +instance DefaultServiceConfiguration (Route53Configuration UriOnlyQuery) where + defServiceConfig = route53 + debugServiceConfig = route53 + +route53EndpointUsClassic :: B.ByteString +route53EndpointUsClassic = "route53.amazonaws.com" + +route53ApiVersionRecent :: B.ByteString +route53ApiVersionRecent = "2012-02-29" + +route53XmlNamespaceRecent :: Text +route53XmlNamespaceRecent = "https://route53.amazonaws.com/doc/" `T.append` T.decodeUtf8 route53ApiVersionRecent `T.append` "/" + +route53 :: Route53Configuration qt +route53 = Route53Configuration + { route53Protocol = HTTPS + , route53Endpoint = route53EndpointUsClassic + , route53Port = defaultPort HTTPS + , route53ApiVersion = route53ApiVersionRecent + , route53XmlNamespace = route53XmlNamespaceRecent + } + +-- -------------------------------------------------------------------------- -- +-- Error + +-- TODO route53 documentation seem to indicate that there is also a type field in the error response body. +-- http://docs.amazonwebservices.com/Route53/latest/DeveloperGuide/ResponseHeader_RequestID.html + +data Route53Error = Route53Error + { route53StatusCode :: HTTP.Status + , route53ErrorCode :: Text + , route53ErrorMessage :: Text + } deriving (Show, Typeable) + +instance C.Exception Route53Error + +-- -------------------------------------------------------------------------- -- +-- Metadata + +data Route53Metadata = Route53Metadata + { requestId :: Maybe T.Text + } deriving (Show, Typeable) + +instance Loggable Route53Metadata where + toLogText (Route53Metadata rid) = "Route53: request ID=" `mappend` + fromMaybe "" rid + +instance Monoid Route53Metadata where + mempty = Route53Metadata Nothing + Route53Metadata r1 `mappend` Route53Metadata r2 = Route53Metadata (r1 `mplus` r2) + +-- -------------------------------------------------------------------------- -- +-- Query + +route53SignQuery :: Method + -> B.ByteString + -> [(B.ByteString, B.ByteString)] + -> Maybe XML.Element + -> Route53Configuration qt + -> SignatureData + -> SignedQuery +route53SignQuery method resource query body Route53Configuration{..} sd + = SignedQuery { + sqMethod = method + , sqProtocol = route53Protocol + , sqHost = route53Endpoint + , sqPort = route53Port + , sqPath = route53ApiVersion `B.append` resource + , sqQuery = HTTP.simpleQueryToQuery query' + , sqDate = Just $ signatureTime sd + , sqAuthorization = Nothing + , sqContentType = Nothing + , sqContentMd5 = Nothing + , sqAmzHeaders = [("X-Amzn-Authorization", authorization)] + , sqOtherHeaders = [] + , sqBody = renderBody `fmap` body + , sqStringToSign = stringToSign + } + where + stringToSign = fmtRfc822Time (signatureTime sd) + credentials = signatureCredentials sd + accessKeyId = accessKeyID credentials + authorization = B.concat [ "AWS3-HTTPS AWSAccessKeyId=" + , accessKeyId + , ", Algorithm=HmacSHA256, Signature=" + , signature credentials HmacSHA256 stringToSign + ] + query' = ("AWSAccessKeyId", accessKeyId) : query + + renderBody b = HTTP.RequestBodyLBS . XML.renderLBS XML.def $ XML.Document + { XML.documentPrologue = XML.Prologue [] Nothing [] + , XML.documentRoot = b { elementAttributes = addNamespace (elementAttributes b) } + , XML.documentEpilogue = [] + } + addNamespace attrs = insert "xmlns" route53XmlNamespace attrs + + +-- -------------------------------------------------------------------------- -- +-- Response + +-- TODO: the documentation seems to indicate that in case of errors the requestId is returned in the body +-- Have a look at Ses/Response.hs how to parse the requestId element. We may try both (header and +-- body element) on each response and sum the results with `mplus` in the Maybe monad. +-- http://docs.amazonwebservices.com/Route53/latest/DeveloperGuide/ResponseHeader_RequestID.html + +route53ResponseConsumer :: (Cu.Cursor -> Response Route53Metadata a) + -> IORef Route53Metadata + -> HTTPResponseConsumer a +route53ResponseConsumer inner metadataRef response = + xmlCursorConsumer parse metadataRef response + where + status = (HTTP.responseStatus response) + headers = (HTTP.responseHeaders response) + + parse cursor = do + tellMetadata . Route53Metadata . fmap decodeUtf8 $ findHeaderValue headers hRequestId + case cursor $/ Cu.laxElement "Error" of + [] -> inner cursor + (err:_) -> fromError err + + fromError cursor = do + errCode <- force "Missing Error Code" $ cursor $// elContent "Code" + errMessage <- force "Missing Error Message" $ cursor $// elContent "Message" + throwM $ Route53Error status errCode errMessage + + +route53CheckResponseType :: MonadThrow m => a -> Text -> Cu.Cursor -> m a +route53CheckResponseType a n c = do + _ <- force ("Expected response type " ++ unpack n) (Cu.laxElement n c) + return a + +-- TODO analyse the possible response types. I think there are common patterns. +-- Collect common code from the Commands here + +-- -------------------------------------------------------------------------- -- +-- Model + +class Route53Id r where + idQualifier :: r -> T.Text + idText :: r -> T.Text + + asId :: T.Text -> r + asId t = asId' . fromJust .T.stripPrefix (qualifiedIdTextPrefix (undefined::r)) $ t + + qualifiedIdTextPrefix :: r -> T.Text + qualifiedIdTextPrefix r = "/" `T.append` idQualifier r `T.append` "/" + + qualifiedIdText :: r -> T.Text + qualifiedIdText r = qualifiedIdTextPrefix r `T.append` idText r + + -- | Helper for defining 'asId'. Constructs 'r' from a 'T.Text' assuming that + -- the qualifier with already stripped from the argument. + -- + -- Define either this or 'asId'. Usually defining 'asId'' is easier. + asId' :: (T.Text -> r) + asId' t = asId $ qualifiedIdTextPrefix (undefined::r) `T.append` t + +--instance (Route53Id r) => IsString r where +-- fromString = HostedZoneId . fromJust . T.stripPrefix (idPrefix undefined) . T.pack + +-- -------------------------------------------------------------------------- -- +-- DNS + +data RecordType = A | AAAA | NS | TXT | MX | CNAME | SOA | PTR | SRV | SPF | UNKNOWN Int + deriving (Eq, Show, Read) + +typeToString :: RecordType -> String +typeToString = show + +typeToText :: RecordType -> T.Text +typeToText = T.pack . typeToString + +-- -------------------------------------------------------------------------- -- +-- HostedZone + +newtype HostedZoneId = HostedZoneId { hziText :: T.Text } + deriving (Show, IsString, Eq) + +instance Route53Id HostedZoneId where + idQualifier = const "hostedzone" + idText = hziText + asId' = HostedZoneId + +newtype Domain = Domain { dText :: T.Text } + deriving (Show, Eq) + +instance IsString Domain where + fromString = Domain . T.pack + +type HostedZones = [HostedZone] + +data HostedZone = HostedZone + { hzId :: HostedZoneId + , hzName :: Domain + , hzCallerReference :: T.Text + , hzComment :: T.Text + , hzResourceRecordSetCount :: Int + } deriving (Show) + +instance Route53Parseable HostedZones where + r53Parse cursor = do + c <- force "Missing HostedZones element" $ cursor $.// laxElement "HostedZones" + sequence $ c $/ laxElement "HostedZone" &| r53Parse + +instance Route53Parseable HostedZone where + r53Parse cursor = do + c <- force "Missing HostedZone element" $ cursor $.// laxElement "HostedZone" + zoneId <- force "Missing hostedZoneId element" $ c $/ elContent "Id" &| asId + name <- force "Missing Name element" $ c $/ elContent "Name" &| Domain + callerReference <- force "Missing CallerReference element" $ c $/ elContent "CallerReference" + let comment = case (c $// elContent "Comment") of { [] -> T.empty; (x:_) -> x } + resourceRecordSetCount <- forceM "Missing ResourceRecordCount" $ c $/ elCont "ResourceRecordSetCount" &| readInt + return $ HostedZone zoneId name callerReference comment resourceRecordSetCount + +instance Route53XmlSerializable HostedZone where + + toXml HostedZone{..} = XML.Element "HostedZone" empty [xml| + #{idText hzId} + #{dText hzName} + #{hzCallerReference} + + #{hzComment} + #{intToText hzResourceRecordSetCount} + |] + +instance Route53XmlSerializable HostedZones where + toXml hostedZones = XML.Element "HostedZones" empty $ (XML.NodeElement . toXml) `map` hostedZones + +-- -------------------------------------------------------------------------- -- +-- Delegation Set + +type Nameservers = [Nameserver] + +type Nameserver = Domain + +data DelegationSet = DelegationSet { dsNameserver1 :: Domain + , dsNameserver2 :: Domain + , dsNameserver3 :: Domain + , dsNameserver4 :: Domain + } deriving (Show) + +dsNameservers :: DelegationSet -> [Domain] +dsNameservers DelegationSet{..} = [dsNameserver1, dsNameserver2, dsNameserver3, dsNameserver4] + +instance Route53Parseable DelegationSet where + r53Parse cursor = do + c <- force "Missing DelegationSet element" $ cursor $.// laxElement "DelegationSet" + [ns1, ns2, ns3, ns4] <- forceTake 4 "Expected four nameservers in DelegationSet" =<< r53Parse c + return $ DelegationSet ns1 ns2 ns3 ns4 + +instance Route53Parseable Nameservers where + r53Parse cursor = do + c <- force "Missing Nameservers element" $ cursor $.// laxElement "Nameservers" + sequence $ c $/ laxElement "Nameserver" &| r53Parse + +instance Route53Parseable Nameserver where + r53Parse cursor = + force "Missing Nameserver element" $ cursor $.// elContent "Nameserver" &| Domain + +-- -------------------------------------------------------------------------- -- +-- ResourceRecordSet + +data REGION = ApNorthEast1 + | ApSouthEast2 + | EuWest1 + | SaEast1 + | UsEast1 + | UsWest1 + | UsWest2 + | UnknownRegion + deriving (Eq) + +instance Show REGION where + show ApNorthEast1 = "ap-north-east-1" + show ApSouthEast2 = "ap-South-east-2" + show EuWest1 = "eu-west-1" + show SaEast1 = "sa-east-1" + show UsEast1 = "us-east-1" + show UsWest1 = "us-west-1" + show UsWest2 = "us-west-2" + show UnknownRegion = "unknown" + +regionToText :: REGION -> T.Text +regionToText = T.pack . show + +regionFromString :: String -> REGION +regionFromString "ap-north-east-1" = ApNorthEast1 +regionFromString "ap-South-east-2" = ApSouthEast2 +regionFromString "eu-west-1" = EuWest1 +regionFromString "sa-east-1" = SaEast1 +regionFromString "us-east-1" = UsEast1 +regionFromString "us-west-1" = UsWest1 +regionFromString "us-west-2" = UsWest2 +regionFromString _ = UnknownRegion + +type ResourceRecords = [ResourceRecord] + +newtype ResourceRecord = ResourceRecord { value :: T.Text } + deriving (Show, Eq) + +data AliasTarget = AliasTarget { atHostedZoneId :: HostedZoneId + , atDNSName :: Domain + } deriving (Show) + +data ResourceRecordSet = ResourceRecordSet { rrsName :: Domain + , rrsType :: RecordType + , rrsAliasTarget :: Maybe AliasTarget + , rrsSetIdentifier :: Maybe T.Text + , rrsWeight :: Maybe Int + , rrsRegion :: Maybe REGION + , rrsTTL :: Maybe Int + , rrsRecords :: ResourceRecords + } deriving (Show) + +type ResourceRecordSets = [ResourceRecordSet] + +instance Route53XmlSerializable ResourceRecordSet where + + toXml ResourceRecordSet{..} = XML.Element "ResourceRecordSet" empty [xml| + #{dText rrsName} + #{typeToText rrsType} + $maybe a <- rrsAliasTarget + ^{[XML.NodeElement (toXml a)]} + $maybe i <- rrsSetIdentifier + #{i} + $maybe w <- rrsWeight + #{intToText w} + $maybe r <- rrsRegion + #{regionToText r} + $maybe t <- rrsTTL + #{intToText t} + $if not (null rrsRecords) + + $forall record <- rrsRecords + ^{[XML.NodeElement (toXml record)]} + |] + +instance Route53XmlSerializable ResourceRecord where + toXml ResourceRecord{..} = XML.Element "ResourceRecord" empty [xml| #{value} |] + +instance Route53XmlSerializable AliasTarget where + toXml AliasTarget{..} = XML.Element "AliasTarget" empty [xml| + #{idText atHostedZoneId} + #{dText atDNSName} + |] + +instance Route53Parseable ResourceRecordSets where + r53Parse cursor = do + c <- force "Missing ResourceRecordSets element" $ cursor $.// laxElement "ResourceRecordSets" + sequence $ c $/ laxElement "ResourceRecordSet" &| r53Parse + +instance Route53Parseable ResourceRecordSet where + r53Parse cursor = do + c <- force "Missing ResourceRecordSet element" $ cursor $.// laxElement "ResourceRecordSet" + name <- force "Missing name element" $ c $/ elContent "Name" &| Domain + dnsType <- force "Missing type element" $ c $/ elCont "Type" &| read + ttl <- listToMaybe `liftM` (sequence $ c $/ elCont "TTL" &| readInt) + alias <- listToMaybe `liftM` (sequence $ c $/ laxElement "AliasTarget" &| r53Parse) + let setIdentifier = listToMaybe $ c $/ elContent "SetIdentifier" + weight <- listToMaybe `liftM` (sequence $ c $/ elCont "Weight" &| readInt) + let region = listToMaybe $ c $/ elCont "Region" &| regionFromString + resourceRecords <- r53Parse c + return $ ResourceRecordSet name dnsType alias setIdentifier weight region ttl resourceRecords + +-- TODO is there any constraint on the number of records? +-- TODO check constraints on type + +instance Route53Parseable AliasTarget where + r53Parse cursor = do + c <- force "Missing AliasTarget element" $ cursor $.// laxElement "AliasTarget" + zoneId <- force "Missing HostedZoneId element" $ c $/ elContent "HostedZoneId" &| asId + dnsName <- force "Missing DNSName element" $ c $/ elContent "DNSName" &| Domain + return $ AliasTarget zoneId dnsName + +instance Route53Parseable ResourceRecords where + r53Parse cursor = do + c <- force "Missing ResourceRecords element" $ cursor $.// laxElement "ResourceRecords" + sequence $ c $/ laxElement "ResourceRecord" &| r53Parse + +instance Route53Parseable ResourceRecord where + r53Parse cursor = do + c <- force "Missing ResourceRecord element" $ cursor $.// laxElement "ResourceRecord" + force "Missing Value element" $ c $/ elContent "Value" &| ResourceRecord + +-- -------------------------------------------------------------------------- -- +-- Change Info + +data ChangeInfoStatus = PENDING | INSYNC + deriving (Show, Read) + +newtype ChangeId = ChangeId { changeIdText :: T.Text } + deriving (Show, Eq) + +instance Route53Id ChangeId where + idQualifier = const "change" + idText = changeIdText + asId' = ChangeId + +data ChangeInfo = ChangeInfo { ciId :: ChangeId + , ciStatus :: ChangeInfoStatus + , ciSubmittedAt :: UTCTime + } deriving (Show) + +instance Route53Parseable ChangeInfo where + r53Parse cursor = do + c <- force "Missing ChangeInfo element" $ cursor $.// laxElement "ChangeInfo" + ciId <- force "Missing Id element" $ c $/ elContent "Id" &| asId + status <- force "Missing Status element" $ c $/ elCont "Status" &| read + submittedAt <- force "Missing SubmittedAt element" $ c $/ elCont "SubmittedAt" &| utcTime + return $ ChangeInfo ciId status submittedAt + where + utcTime str = fromJust $ parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" str + +-- -------------------------------------------------------------------------- -- +-- Parser and Serialization Utilities + +-- | A class for Route53 XML response parsers +-- +-- TODO there is a lot of Boilerplat here. With only little overhead serializatin and deserialization +-- could be derived from the instance declaration. Maybe some DLS would be a goold solution + +class Route53Parseable r where + r53Parse :: MonadThrow m => Cu.Cursor -> m r + +-- | Takes the first @n@ elements from a List and injects them into a 'MonadPlus'. +-- Causes a failure in the 'Control.Failure' Monad if there are not enough elements +-- in the List. +forceTake :: (MonadThrow f, MonadPlus m) => Int -> String -> [a] -> f (m a) +forceTake 0 _ _ = return mzero +forceTake _ e [] = force e [] +forceTake n e l = do + h <- force e l + t <- forceTake (n-1) e (tail l) + return $ return h `mplus` t + +class Route53XmlSerializable r where + toXml :: r -> XML.Element + +intToText :: Int -> T.Text +intToText = T.pack . show + +-- -------------------------------------------------------------------------- -- +-- Utility methods that extend the functionality of 'Network.HTTP.Types' + +hRequestId :: HTTP.HeaderName +hRequestId = "x-amzn-requestid" + +findHeader:: [HTTP.Header] -> HTTP.HeaderName -> Maybe HTTP.Header +findHeader headers hName = find ((==hName).fst) headers + +findHeaderValue :: [HTTP.Header] -> HTTP.HeaderName -> Maybe B.ByteString +findHeaderValue headers hName = lookup hName headers + diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,18 @@ +# 0.1.1 - 4th August, 2014 + +* Fix Alias target requests. + +# 0.1.0 - 26th April, 2014 + +* Move from `failure` package to `resourcet` package. + +# 0.0.2 - 6th September, 2013 + +* Fix attribution of work and copyright. +* Improve cabal description of package. + +# 0.0.1 - 20th August, 2013 + +* Initial release! +* Fix up bugs and regressions from changed package versions. + diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS.md @@ -0,0 +1,7 @@ +# AWS Route53 Contributors + +* Aristid Breitkreuz +* Vladimir Kirillov +* Amit Levy +* David Terei + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2013, Aristid Breitkreuz +Copyright (c) 2013, AlephCloud Systems, Inc +Copyright (c) 2013, MemCachier, Inc + +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 Aristid Breitkreuz, AlephCloud Systems, + MemCachier 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/vk-aws-route53.cabal b/vk-aws-route53.cabal new file mode 100644 --- /dev/null +++ b/vk-aws-route53.cabal @@ -0,0 +1,61 @@ +name: vk-aws-route53 +version: 0.1.2 +synopsis: Amazon Route53 DNS service plugin for the aws package. +description: Amazon Route53 DNS service plugin for the aws package. +license: BSD3 +license-file: LICENSE +author: Aristid Breitkreuz; AlephCloud Systems, Inc; MemCachier, Inc +maintainer: MemCachier, Inc . +author: Aristid Breitkreuz; AlephCloud Systems, Inc; MemCachier, Inc +category: Web +build-type: Simple +cabal-version: >=1.10 +extra-source-files: CHANGELOG.md, CONTRIBUTORS.md + +Library + Exposed-modules: + Aws.Route53, + Aws.Route53.Core + Aws.Route53.Commands, + Aws.Route53.Commands.ListHostedZones, + Aws.Route53.Commands.ListResourceRecordSets, + Aws.Route53.Commands.ChangeResourceRecordSets, + Aws.Route53.Commands.GetHostedZone, + Aws.Route53.Commands.CreateHostedZone, + Aws.Route53.Commands.DeleteHostedZone, + Aws.Route53.Commands.GetChange, + Aws.Route53.Commands.GetDate + + Build-depends: + aws >= 0.9, + base >= 4 && < 6, + bytestring >= 0.9, + containers >= 0.4, + http-conduit >= 1.6, + http-types >= 0.7, + old-locale == 1.*, + resourcet, + text >= 0.11, + time >= 1.1.4, + xml-conduit >= 1.0.1, + xml-hamlet >= 0.3.0 + + GHC-Options: -Wall + + Default-Language: Haskell2010 + Default-Extensions: + RecordWildCards, + TypeFamilies, + MultiParamTypeClasses, + FlexibleInstances, + OverloadedStrings + +Source-repository this + type: git + location: https://github.com/memcachier/aws-route53.git + tag: 0.1.0 + +Source-repository head + type: git + location: https://github.com/memcachier/aws-route53.git +