module Aws.Route53.Core
(
Route53Configuration(..)
, route53EndpointUsClassic
, route53
, Route53Error(..)
, Route53Metadata(..)
, route53SignQuery
, route53ResponseConsumer
, route53CheckResponseType
, RecordType(..)
, typeToString
, HostedZone (..)
, HostedZones
, Domain(..)
, HostedZoneId(..)
, DelegationSet(..)
, Nameserver
, Nameservers
, dsNameservers
, REGION(..)
, ResourceRecordSets
, ResourceRecordSet(..)
, ResourceRecords
, ResourceRecord(..)
, AliasTarget(..)
, ChangeInfo(..)
, ChangeInfoStatus(..)
, ChangeId(..)
, Route53Parseable(..)
, Route53XmlSerializable(..)
, Route53Id(..)
, 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 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 Control.Failure as F
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
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
}
data Route53Error = Route53Error
{ route53StatusCode :: HTTP.Status
, route53ErrorCode :: Text
, route53ErrorMessage :: Text
} deriving (Show, Typeable)
instance C.Exception Route53Error
data Route53Metadata = Route53Metadata
{ requestId :: Maybe T.Text
} deriving (Show, Typeable)
instance Loggable Route53Metadata where
toLogText (Route53Metadata rid) = "Route53: request ID=" `mappend`
fromMaybe "<none>" rid
instance Monoid Route53Metadata where
mempty = Route53Metadata Nothing
Route53Metadata r1 `mappend` Route53Metadata r2 = Route53Metadata (r1 `mplus` r2)
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
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"
F.failure $ Route53Error status errCode errMessage
route53CheckResponseType :: F.Failure XmlException m => a -> Text -> Cu.Cursor -> m a
route53CheckResponseType a n c = do
_ <- force ("Expected response type " ++ unpack n) (Cu.laxElement n c)
return a
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
asId' :: (T.Text -> r)
asId' t = asId $ qualifiedIdTextPrefix (undefined::r) `T.append` t
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
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|
<Id>#{idText hzId}
<Name>#{dText hzName}
<CallerReference>#{hzCallerReference}
<Config>
<Comment>#{hzComment}
<ResourceRecordSetCount>#{intToText hzResourceRecordSetCount}
|]
instance Route53XmlSerializable HostedZones where
toXml hostedZones = XML.Element "HostedZones" empty $ (XML.NodeElement . toXml) `map` hostedZones
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
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|
<Name>#{dText rrsName}
<Type>#{typeToText rrsType}
$maybe a <- rrsAliasTarget
<AliasTarget>
^{[XML.NodeElement (toXml a)]}
$maybe i <- rrsSetIdentifier
<SetIdentifier>#{i}
$maybe w <- rrsWeight
<Weight>#{intToText w}
$maybe r <- rrsRegion
<Region>#{regionToText r}
$maybe t <- rrsTTL
<TTL>#{intToText t}
<ResourceRecords>
$forall record <- rrsRecords
^{[XML.NodeElement (toXml record)]}
|]
instance Route53XmlSerializable ResourceRecord where
toXml ResourceRecord{..} = XML.Element "ResourceRecord" empty [xml| <Value>#{value} |]
instance Route53XmlSerializable AliasTarget where
toXml AliasTarget{..} = XML.Element "AliasTarget" empty [xml|
<HostedZoneId>#{idText atHostedZoneId}
<DNSName>#{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
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
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
class Route53Parseable r where
r53Parse :: F.Failure XmlException m => Cu.Cursor -> m r
forceTake :: (F.Failure XmlException 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 (n1) e (tail l)
return $ return h `mplus` t
class Route53XmlSerializable r where
toXml :: r -> XML.Element
intToText :: Int -> T.Text
intToText = T.pack . show
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