diff --git a/Aws/Route53.hs b/Aws/Route53.hs new file mode 100644 index 00000000..6c4f54f8 --- /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 index 00000000..ecbe75b8 --- /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 index 00000000..a6a8d9e0 --- /dev/null +++ b/Aws/Route53/Commands/ChangeResourceRecordSets.hs @@ -0,0 +1,67 @@ +-- ------------------------------------------------------ -- +-- 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 + 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 index 00000000..e941a489 --- /dev/null +++ b/Aws/Route53/Commands/CreateHostedZone.hs @@ -0,0 +1,64 @@ +-- ------------------------------------------------------ -- +-- 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 () "GetHostedZoneResponse" 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 index 00000000..e78743aa --- /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 index 00000000..6b5deaaa --- /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 index 00000000..4b91e44d --- /dev/null +++ b/Aws/Route53/Commands/GetDate.hs @@ -0,0 +1,61 @@ +-- ------------------------------------------------------ -- +-- 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.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 _ _ _ headers _ = return $ GetDateResponse date + where + -- TODO add proper error handling + date = fromJust $ do + str <- findHeaderValue headers 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 + diff --git a/Aws/Route53/Commands/GetHostedZone.hs b/Aws/Route53/Commands/GetHostedZone.hs new file mode 100644 index 00000000..51407837 --- /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 index 00000000..f4062506 --- /dev/null +++ b/Aws/Route53/Commands/ListHostedZones.hs @@ -0,0 +1,62 @@ +-- ------------------------------------------------------ -- +-- 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 index 00000000..65e13792 --- /dev/null +++ b/Aws/Route53/Commands/ListResourceRecordSets.hs @@ -0,0 +1,96 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +-- | GET ListResourceRecordSets +-- +-- Lists the resource record sets for a Route53 hosted zone. The hosted zone is identifed 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 laltency 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 index 00000000..0934dabd --- /dev/null +++ b/Aws/Route53/Core.hs @@ -0,0 +1,556 @@ +-- ------------------------------------------------------ -- +-- 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 Data.List (find) +import Data.Map (insert, empty) +import Data.Maybe (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 Network.HTTP.Types.Header 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 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 status headers = + xmlCursorConsumer parse metadataRef status headers + where + 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 + +-- 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" + comment <- force "Missing Comment element" $ c $// elContent "Comment" + 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} + + $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 :: F.Failure XmlException 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 :: (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 (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/Examples/Route53/AttemptT.hs b/Examples/Route53/AttemptT.hs new file mode 100644 index 00000000..b9ae0add --- /dev/null +++ b/Examples/Route53/AttemptT.hs @@ -0,0 +1,95 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} + +-- -------------------------------------------------------------------------- -- +-- | AttemptT - a lazy monad transformer for the 'Attempt' Monad. +-- +module AttemptT +( AttemptT(..) +, mapAttemptT +, failAttempt +, succeedAttempt +, listToAttemptT +, handleFailure +) where + +import Data.Typeable +import Data.Attempt + +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Applicative +import Control.Monad + +import Control.Exception + +newtype AttemptT m a = AttemptT { runAttemptT :: m (Attempt a) } + +mapAttemptT :: (m (Attempt a) -> n (Attempt b)) -> AttemptT m a -> AttemptT n b +mapAttemptT f = AttemptT . f . runAttemptT + +instance (Functor m) => Functor (AttemptT m) where + fmap f = mapAttemptT (fmap (fmap f)) + +instance (Functor m, Monad m) => Applicative (AttemptT m) where + pure = return + (<*>) = ap + +instance (Functor m, Monad m) => Alternative (AttemptT m) where + empty = mzero + (<|>) = mplus + +data AttemptException = FailException String + | EmptyException + deriving (Show, Typeable) + +instance Exception AttemptException + +instance (Monad m) => Monad (AttemptT m) where + fail e = AttemptT $ return (Failure (FailException e)) + return a = AttemptT $ return (Success a) + m >>= k = AttemptT $ do + a <- runAttemptT m + case a of + Failure e -> return (Failure e) + Success s -> runAttemptT (k s) + +instance (Monad m) => MonadPlus (AttemptT m) where + mzero = AttemptT $ return (Failure EmptyException) + m `mplus` n = AttemptT $ do + a <- runAttemptT m + case a of + Failure _ -> runAttemptT n + Success s -> return (Success s) + +instance MonadTrans AttemptT where + lift m = AttemptT $ do + a <- m + return (Success a) + +instance (MonadIO m) => MonadIO (AttemptT m) where + liftIO = lift . liftIO + +failAttempt :: (Monad m, Exception e) => e -> AttemptT m a +failAttempt = AttemptT . return . Failure + +succeedAttempt :: (Monad m) => a -> AttemptT m a +succeedAttempt = return + +listToAttemptT :: (Monad m) => [a] -> AttemptT m a +listToAttemptT [] = failAttempt $ FailException "empty result list" +listToAttemptT (h:_) = succeedAttempt h + +handleFailure :: (Monad m) => (forall e . Exception e => e -> m b) -> AttemptT m b -> AttemptT m b +handleFailure f n = AttemptT $ do + a <- runAttemptT n + case a of + Failure e -> f e >>= return . Success + Success s -> return (Success s) + diff --git a/Examples/Route53/LICENSE b/Examples/Route53/LICENSE new file mode 100644 index 00000000..f0e5fca1 --- /dev/null +++ b/Examples/Route53/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, AlephCloud Systems, 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 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/Examples/Route53/README.md b/Examples/Route53/README.md new file mode 100644 index 00000000..1d6b209e --- /dev/null +++ b/Examples/Route53/README.md @@ -0,0 +1,41 @@ +r53-dyndns - AWS Route53 Usage Example +====================================== + +The program r53-dyndns is simple dynamic DNS client that uses a AWS Route53 +hosted zone as backend DNS Server. It monitors the publically visible IP +address of the local machine (through http://api.externalip.net/ip/) and +maintains the correspodings A record in an AWS Route53 hosted zone to point +that IP. + +Beside of being useful, the purpose of this program is to demonstrate the usage +of the Haskell AWS Route53 API. + +INSTALLATION +============ + +```bash +cabal configure +cabal build +cabal install +``` + +USAGE +===== + +For usage information type `r53-dyndns --help`. + +RUNNING AS A SERVICE +==================== + +On recent Ubuntu distributions edit the file `contrib/r53-dyndns.conf` +according to your needs and copy to `/etc/init/r53-dyndns.conf`. + +TODO +==== + +* Add support for setting static IP addresses +* More generally, support different ways to determine the IPv4 address. +* Better error handling: retry or abort depending on the type of the error. +* Make the DNS server for the initial lookup configurable. +* Add option looking up the A record in the hosted zone itself. + diff --git a/Examples/Route53/Utils.hs b/Examples/Route53/Utils.hs new file mode 100644 index 00000000..2abc857c --- /dev/null +++ b/Examples/Route53/Utils.hs @@ -0,0 +1,253 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Utils where + +import Data.Text (Text, pack, unpack) +import Data.List (find) +import Data.Attempt (Attempt(..)) + +import Control.Monad (MonadPlus, mplus) +import Control.Applicative (Applicative, (<$>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.List (runListT, ListT(..)) +import Control.Concurrent (threadDelay) + +import Network.HTTP.Conduit (Manager, withManager) +import Data.IP (IPv4) + +import Aws (aws, Response(..), Transaction, DefaultServiceConfiguration, + ServiceConfiguration, defServiceConfig, ResponseMetadata, + awsIteratedAll, Configuration) +import Aws.Core (NormalQuery, IteratedTransaction) +import Aws.Route53 + +import AttemptT + +-- -------------------------------------------------------------------------- -- +-- Request Utils + +-- | extract result of an 'Attempt' from a 'Response' +-- +getResult :: Response m a -> Attempt a +getResult (Response _ a) = a + +-- | Make a request using the base configuration and the default +-- service configuration. +-- +makeDefaultRequest :: ( Transaction r a + , Functor m + , MonadIO m + , DefaultServiceConfiguration (ServiceConfiguration r NormalQuery) + ) + => Configuration -> Manager -> r -> m (Response (ResponseMetadata a) a) +makeDefaultRequest cfg manager request = do + let scfg = defServiceConfig + aws cfg scfg manager request + +-- | Make an iterated request using the base configuration and the default +-- service configuration. +-- +makeDefaultRequestAll :: ( IteratedTransaction r a + , Functor m + , MonadIO m + , DefaultServiceConfiguration (ServiceConfiguration r NormalQuery) + ) + => Configuration -> Manager -> r -> m (Response [ResponseMetadata a] a) +makeDefaultRequestAll cfg manager request = do + let scfg = defServiceConfig + awsIteratedAll cfg scfg manager request + +-- | Executes the given request using the default configuration and a fresh +-- connection manager. Extracts the enclosed response body and returns it +-- within the IO monad. +-- +makeSingleRequest :: ( Transaction r a + , Show r + , DefaultServiceConfiguration (ServiceConfiguration r NormalQuery) + , MonadIO m + ) + => Configuration -> r -> AttemptT m a +makeSingleRequest cfg r = do + AttemptT . liftIO $ getResult <$> withManager (\m -> makeDefaultRequest cfg m r) + +-- | Executes the given iterated request using the default configuration and a fresh +-- connection manager. Extracts the enclosed response body and returns it +-- within the IO monad. +-- +makeSingleRequestAll :: ( IteratedTransaction r a + , Show r + , DefaultServiceConfiguration (ServiceConfiguration r NormalQuery) + , MonadIO m + ) + => Configuration -> r -> AttemptT m a +makeSingleRequestAll cfg r = do + AttemptT . liftIO $ getResult <$> withManager (\m -> makeDefaultRequestAll cfg m r) + +-- | Given a Changeid returns the change info status for the corresponding +-- request. +-- +getChangeStatus :: (MonadIO m, Applicative m) => Configuration -> ChangeId -> AttemptT m ChangeInfoStatus +getChangeStatus cfg changeId = + ciStatus . gcrChangeInfo <$> (makeSingleRequest cfg $ getChange changeId) + +-- | Extracts the ChangeId from a response using the given function to extract +-- the ChangeInfo from the response. +-- +getChangeId :: Functor f => (a -> ChangeInfo) -> f a -> f ChangeId +getChangeId changeInfoExtractor response = ciId . changeInfoExtractor <$> response + +-- | Example usage of getChangeId. +-- +getChangeResourceRecordSetsResponseChangeId :: Functor f => f ChangeResourceRecordSetsResponse -> f ChangeId +getChangeResourceRecordSetsResponseChangeId response = getChangeId crrsrChangeInfo response + +-- TODO implement wait for INSYNC + +-- -------------------------------------------------------------------------- -- +-- Hosted Zones + +-- | Get all hosted zones of the user. +-- +getAllZones :: (MonadIO m, Applicative m) => Configuration -> AttemptT m HostedZones +getAllZones cfg = lhzrHostedZones <$> makeSingleRequestAll cfg listHostedZones + +-- | Get a hosted zone by its 'HostedZoneId'. +-- +getZoneById :: (MonadIO m, Applicative m) => Configuration -> HostedZoneId -> AttemptT m HostedZone +getZoneById cfg hzid = ghzrHostedZone <$> makeSingleRequest cfg (getHostedZone hzid) + +-- | Get a hosted zone by its domain name. +-- +-- Results in an error if no hosted zone exists for the given domain name. +-- +getZoneByName :: (MonadIO m, Applicative m) => Configuration -> Domain -> AttemptT m HostedZone +getZoneByName cfg z = maybe (fail err) return =<< (find ((z==) . hzName) <$> getAllZones cfg) + where + err = "Hosted zone not found: " ++ unpack (dText z) + + +-- | Returns the hosted zone id of the hosted zone for the given domain. +-- +getZoneIdByName :: (MonadIO m, Applicative m) => Configuration -> Domain -> AttemptT m HostedZoneId +getZoneIdByName cfg hzName = hzId <$> getZoneByName cfg hzName + +-- -------------------------------------------------------------------------- -- +-- Resource Records Sets + +-- | Simplified construction for a ResourceRecordSet. +-- +simpleResourceRecordSet :: Domain -> RecordType -> Int -> Text -> ResourceRecordSet +simpleResourceRecordSet domain rtype ttl value = + ResourceRecordSet domain rtype Nothing Nothing Nothing Nothing (Just ttl) [(ResourceRecord value)] + +-- | Returns the resource record sets in the hosted zone with the given domain +-- name. +-- +-- Note the 'zName' is the domain name of the hosted zone itself. +-- +getResourceRecordSetsByHostedZoneName :: (MonadIO m, Applicative m) => Configuration -> Domain -> AttemptT m ResourceRecordSets +getResourceRecordSetsByHostedZoneName cfg zName = do + hzid <- getZoneIdByName cfg zName + lrrsrResourceRecordSets <$> makeSingleRequestAll cfg (listResourceRecordSets hzid) + +-- | Lists all resource record sets in the hosted zone with the given hosted +-- zone id. +-- +getResourceRecordSets :: (MonadIO m, Applicative m) => Configuration -> HostedZoneId -> AttemptT m ResourceRecordSets +getResourceRecordSets cfg hzid = + lrrsrResourceRecordSets <$> makeSingleRequestAll cfg (listResourceRecordSets hzid) + +-- | Lists all resource record sets in the given hosted zone for the given +-- domain. +-- +getResourceRecordSetsByDomain :: (MonadIO m, Applicative m) => Configuration -> HostedZoneId -> Domain -> AttemptT m ResourceRecordSets +getResourceRecordSetsByDomain cfg hzid domain = do + filter ((== domain) . rrsName) <$> getResourceRecordSets cfg hzid + +-- | Returns all resource records sets in the hosted zone with the given hosted +-- zone id for the given DNS record type. +-- +getResourceRecordSetsByType :: (MonadIO m, Applicative m) => Configuration -> HostedZoneId -> RecordType -> AttemptT m ResourceRecordSets +getResourceRecordSetsByType cfg hzid dnsRecordType = + filter ((== dnsRecordType) . rrsType) <$> getResourceRecordSets cfg hzid + +-- | Returns all resource records sets in the hosted zone with the given hosted +-- zone id for the given domain and the given DNS record type. +-- +getResourceRecordSetsByDomainAndType :: (MonadIO m, Applicative m) => Configuration -> HostedZoneId -> Domain -> RecordType -> AttemptT m ResourceRecordSets +getResourceRecordSetsByDomainAndType cfg hzid domain dnsRecordType = + let f ResourceRecordSet{..} = (rrsType == dnsRecordType) && (rrsName == domain) + in filter f <$> getResourceRecordSets cfg hzid + +-- | Updates the resouce records of the given type for the given domain in the +-- given hosted zone using the given mapping function. +-- +-- Recall that the functions in this module are example usages of the +-- Aws.Route53 module. In a production environment one would reuse the same +-- connection manager and configuration for all involved requests. +-- +modifyRecords :: (MonadIO m, Applicative m) + =>Configuration + -> HostedZoneId + -> Domain + -> RecordType + -> ([ResourceRecord] -> [ResourceRecord]) + -> AttemptT m [(ChangeResourceRecordSetsResponse, ChangeResourceRecordSetsResponse)] +modifyRecords cfg cid domain rtype f = runListT $ do + rrs <- ListT $ getResourceRecordSetsByDomainAndType cfg cid domain rtype + let rrs' = rrs { rrsRecords = f (rrsRecords rrs) } + -- FIXME: what if we fail in the second call? Should we try to rollback? + r1 <- lift . makeSingleRequest cfg $ ChangeResourceRecordSets cid Nothing [(DELETE, rrs)] + r2 <- lift . makeSingleRequest cfg $ ChangeResourceRecordSets cid Nothing [(CREATE, rrs')] + return (r1, r2) + +retry :: (MonadIO m, MonadPlus m) => Int -> Int -> m a -> m a +retry _ 1 req = req +retry pause num req | num < 0 = error $ "Illegal argument to retry. Expected positive Int, got " ++ (show num) + | otherwise = req `mplus` (wait >> retry pause (num-1) req) + where + wait = liftIO . threadDelay $ (pause * 1000000) + + +-- | Updates the A record for the given domain in the given zone to the given +-- IP address (encoded as Text). +-- +setARecordRetry :: (MonadIO m, Applicative m) + => Int -- ^ pause between retries (in seconds) + -> Int -- ^ number of retried attempts + -> Configuration -- ^ Configuration + -> HostedZoneId -- ^ Zone ID + -> Domain -- ^ Domain + -> Int -- ^ TTL for the record + -> IPv4 -- ^ The new value for the A record, an IPv4 address + -> AttemptT m [ChangeResourceRecordSetsResponse] +setARecordRetry pause num cfg cid domain ttl ip = runListT $ del `mplus` ins + where + del = do + rrs <- ListT . ret $ getResourceRecordSetsByDomainAndType cfg cid domain A + lift . ret . makeSingleRequest cfg $ ChangeResourceRecordSets cid Nothing [(DELETE, rrs)] + ins = do + let rr = simpleResourceRecordSet domain A ttl (pack . show $ ip) + lift . ret . makeSingleRequest cfg $ ChangeResourceRecordSets cid Nothing [(CREATE, rr)] + ret = retry pause num + +-- | Updates the A record for the given domain in the given zone to the given +-- IP address (encoded as Text). +-- +setARecord :: (MonadIO m, Applicative m) + => Configuration + -> HostedZoneId -- ^ Zone ID + -> Domain -- ^ Domain + -> Int -- ^ TTL for the record + -> IPv4 -- ^ The new value for the A record, an IPv4 address + -> AttemptT m [ChangeResourceRecordSetsResponse] +setARecord cfg cid domain ttl ip = setARecordRetry 0 1 cfg cid domain ttl ip + diff --git a/Examples/Route53/contrib/r53-dyndns.conf b/Examples/Route53/contrib/r53-dyndns.conf new file mode 100644 index 00000000..fc59eac9 --- /dev/null +++ b/Examples/Route53/contrib/r53-dyndns.conf @@ -0,0 +1,46 @@ +description "r53-dyndns" + +start on runlevel [2345] +stop on runlevel [06] + +script + + DYNDNSPROG="/usr/local/bin/r53-dyndns" + + # The user and the group of the service daemon process. You may + # need to create a new system account or use 'root". Using 'root' + # is not discouraged in a production setting. + DYNDNSUSER="dyndns" + DYNDNSGROUP="dyndns" + + # This MUST be an absolute domain name, i.e. it MUST end with a dot + HOSTEDZONE="example.com." + + # This is the subdomain name of the local machine relative to the + # hosted zone name. Leave comment out or leaf black if you want to set + # the A record of the domain of the hosted zone itself. + # SUBDOMAIN="www" + + # Alternatively, the AWS credentials may be defined using environment variables + AWSKEY="default" + AWSKEYSFILE="/etc/aws-keys" + + LOGFILE="/var/log/r53-dyndns.log" + + if [ ! -f "$LOGFILE" ] ; then + touch "$LOGFILE" + chown $DYNDNSUSER:$DYNDNSGROUP "$LOGFILE" + chmod u+w "$LOGFILE" + fi + + SUBDARG="" + if [ -n "$SUBDOMAIN" ] ; then + SUBDARG="--subdomain=$SUBDOMAIN" + fi + + if [ -f /etc/default/r53-dyndns ]; then . /etc/default/r53-dyndns; fi + exec start-stop-daemon --start --quiet --chuid $DYNDNSUSER:$DYNDNSGROUP --chdir /tmp --umask 027 \ + --exec "$DYNDNSPROG" -- "$HOSTEDZONE" $SUBDARG --aws-key="$AWSKEY" --aws-keys-file="$AWSKEYSFILE" --log-file="$LOGFILE"; +end script + + diff --git a/Examples/Route53/r53-dyndns.cabal b/Examples/Route53/r53-dyndns.cabal new file mode 100644 index 00000000..bf65a73e --- /dev/null +++ b/Examples/Route53/r53-dyndns.cabal @@ -0,0 +1,49 @@ +Name: r53-dyndns +Version: 0.1 +Synopsis: A dynamic DNS Client for AWS Route53. + +Description: + A dynamic DNS client that uses a AWS Route53 Hosted Zone as DNS Server. + +Homepage: https://github.com/alephcloud/aws +License: BSD3 +License-file: LICENSE +Author: Lars Kuhtz +Maintainer: lars@alephcloud.com +Copyright: Copyright (c) 2012 AlephCloud, Inc. +Category: Network +Build-type: Simple +Cabal-version: >=1.8 + +Executable r53-dyndns + + Main-is: r53-dyndns.hs + + Build-depends: + base, + transformers >= 0.2.2.0, + bytestring >= 0.9.1.10, + dns >= 0.3.3, + cmdargs >= 0.9.5, + text >= 0.11.2.0, + time >= 1.4, + attempt >= 0.4.0, + iproute >= 1.2.6, + http-conduit >= 1.5.0.3, + old-locale >= 1.0.0.4, + aws >= 0.7 + + Other-modules: + AttemptT + Utils + + ghc-options: -Wall -O2 + +source-repository head + type: git + location: https://github.com/alephcloud/aws.git + +source-repository this + type: git + location: https://github.com/alephcloud/aws.git + tag: tip diff --git a/Examples/Route53/r53-dyndns.hs b/Examples/Route53/r53-dyndns.hs new file mode 100644 index 00000000..bc1f627c --- /dev/null +++ b/Examples/Route53/r53-dyndns.hs @@ -0,0 +1,295 @@ +-- ------------------------------------------------------ -- +-- Copyright © 2012 AlephCloud Systems, Inc. +-- ------------------------------------------------------ -- + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DoAndIfThenElse #-} + +module Main where + +import Prelude hiding (lookup) + +import System.IO (stderr, Handle, withFile, BufferMode(LineBuffering), IOMode(AppendMode), hSetBuffering) +import System.Locale (defaultTimeLocale) + +import Network.HTTP.Conduit (simpleHttp) +import qualified Data.ByteString.Lazy.Char8 as B8 (unpack) +import Data.Text (Text, pack, unpack) +import Data.Text.IO (hPutStrLn) +import Data.Text.Encoding (encodeUtf8) +import Data.Attempt +import Data.Monoid ((<>)) +import Data.IP (IPv4) +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (formatTime) +import Control.Monad (when) +import Control.Applicative ((<$>)) +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (liftIO) +import Control.Exception (finally) + +import Network.DNS (lookup, makeResolvSeed, defaultResolvConf, withResolver, TYPE(A), RDATA(RD_A)) + +import qualified Aws as Aws +import Aws (LogLevel(..), Logger) +import Aws.Route53 (Domain(..), ChangeResourceRecordSetsResponse) + +import Utils hiding (retry) +import qualified Utils (retry) +import AttemptT + +import System.Console.CmdArgs + +-- -------------------------------------------------------------------------- -- +-- Command Line Arguments and Configuration +-- +data DynDnsArgs = DynDnsArgs + { hosted_zone :: String + , subdomain :: String + , ttl :: Int + , sleep :: Int + , retry :: Int + , retry_sleep :: Int + , log_file :: FilePath + , aws_keys_file :: FilePath + , aws_key :: String + } deriving (Show, Data, Typeable) + +dyndnsargs :: DynDnsArgs +dyndnsargs = DynDnsArgs + { ttl = 60 &= help "Value of the time to live header for the A record of the subdomain (default: 60)" &= typ "SECONDS" + , sleep = 60 &= help "Time to sleep after each check and possible reset of the A record of the subdomain (default: 60)" &= typ "SECONDS" + , retry = 4 &= help "Number of times network requests are retried (default: 4)" &= typ "INTEGER" + , retry_sleep = 1 &= help "Time to wait between two retries (defaul: 1)" &= typ "SECONDS" + , aws_keys_file = def &= help "File with the AWS access keys (default: ~/.aws-keys)" &= typFile + , aws_key = def &= help "Aws key to use (default: default)" &= typ "STRING" + , log_file = def &= help "File with where the logs will be written to (default: stderr)" &= typFile + , subdomain = def &= help "If present the A record for the subdomain is updated" &= typ "RELATIVE_DOMAIN" + , hosted_zone = def &= argPos 0 &= typ "HOSTED_ZONE" + } + &= verbosity + &= program "r53-dyndns" + &= summary "r53-dyndns 0.1, © 2012 AlephCloud System, Inc." + &= help "Regulary check and set the A record of the DNS name local machine to the effective public IP address" + &= details [ "This dynamic DNS client sses AWS Route53 as DNS server backend. An Route53 account is need with a configured hosted zone. If a subdomain is provided it must be choosen for the hosted zone. The Haskell AWS package must be configured with the default access key in place." + , "" + , "You must provide the domain of the hosted zone as absolute DNS name (ends with a dot) and the subdomain relative to the hosted zone domain." + ] + +data Config = Config + { confHostedZone :: Domain + , confDomain :: Domain + , confTtl :: Int + , confSleep :: Int + , confRetry :: Int + , confRetrySleep :: Int + , confAws :: Aws.Configuration + , confLog :: Logger + } + +awsConfiguration :: DynDnsArgs -> Logger -> IO Aws.Configuration +awsConfiguration a logger = do + maybeCreds <- awsCredentials (aws_keys_file a) (aws_key a) + creds <- case maybeCreds of + Nothing -> do logger Error $ "Failed to load AWS Credentials." + error "FATAL ERROR: Failed to load AWS Credentials." + Just x -> return x + return $ Aws.Configuration + { Aws.timeInfo = Aws.Timestamp + , Aws.credentials = creds + , Aws.logger = logger + } + where + awsCredentials file key | file == def && key == def = Aws.loadCredentialsDefault + | key == def = Aws.loadCredentialsFromFile file Aws.credentialsDefaultKey + | file == def = do f <- Aws.credentialsDefaultFile + Aws.loadCredentialsFromEnvOrFile f (pack key) + | otherwise = Aws.loadCredentialsFromFile file (pack key) + +-- -------------------------------------------------------------------------- -- +-- Logger +-- + +-- We reuse the simple logging approach from the Aws package. +-- It is not very efficient but for this application we do not need +-- to worry about performance +getLogger :: Handle -> LogLevel -> Logger +getLogger h minlevel level msg = do + when (level >= minlevel) $ do + time <- formatTime defaultTimeLocale "%F %X" <$> getCurrentTime + let m = pack time <> " - " <> pack (show level) <> ": " <> msg + hPutStrLn h m + +logDebug :: Config -> Text -> IO () +logDebug conf msg = (confLog conf) Debug msg + +logInfo :: Config -> Text -> IO () +logInfo conf msg = (confLog conf) Info msg + +logWarning :: Config -> Text -> IO () +logWarning conf msg = (confLog conf) Warning msg + +logError :: Config -> Text -> IO () +logError conf msg = (confLog conf) Error msg + +-- -------------------------------------------------------------------------- -- +-- The r53-dyndns main loop +-- + +-- | The domain process retrieves the current IPv4 address for the given domain from +-- the domain name system and passes that IPv4 address to the 'check' function which +-- run the main loop. +-- +daemon :: Config -> IO () +daemon conf = do + dip <- dnsip conf + logInfo conf $ "Current IPv4 address (A record) in DNS is " <> pack (show dip) <> "." + check conf dip + +realip :: IO IPv4 +realip = read . B8.unpack <$> simpleHttp "http://api.externalip.net/ip/" + +-- TODO Retry should depend on the type of the error. Do not retry on startup. +dnsip :: Config -> IO [IPv4] +dnsip conf = do + rs <- makeResolvSeed defaultResolvConf + withResolver rs $ \resolver -> do + result <- ret $ lookup resolver (toDnsDomain dom) A + case result of + Just ips -> return . map (\(RD_A ip) -> ip) $ ips + Nothing -> do + logWarning conf $ "DNS lookup for " <> dom <> " without result." + return [] + + where + dom = dText . confDomain $ conf + toDnsDomain = encodeUtf8 + ret = Utils.retry (confRetrySleep conf) (confRetry conf) + +check :: Config -> [IPv4] -> IO () + +check conf [ip] = do + rip <- realip + logDebug conf $ "Current public visible IP of the local machine is " <> pack (show rip) <> "." + + let dom = dText (confDomain conf) + + ip' <- if ip == rip + then return [ip] + else do + logInfo conf $ "Real IPv4 address does not match the DNS IPv4 address." + sip <- runAttemptT $ setip conf rip + case sip of + Failure e -> do + logWarning conf $ "Failed to update ip address for " <> dom <> " to " <> pack (show rip) <> ": " <> pack (show e) + return [] + Success _ -> do + logInfo conf $ "Successfully updated ip address for " <> dom <> " to " <> pack (show rip) <> "." + return [rip] + threadDelay $ (confSleep conf) * 1000000 + check conf ip' + +check conf _ = do + logDebug conf $ "No valid single IPv4 address (A record) in DNS." + + rip <- realip + logDebug conf $ "Current public visible IP of the local machine is " <> pack (show rip) <> "." + + let dom = dText (confDomain conf) + + sip <- runAttemptT $ setip conf rip + ip' <- case sip of + Failure e -> do + logWarning conf $ "Failed to update ip address for " <> dom <> " to " <> pack (show rip) <> ": " <> pack (show e) + return [] + Success _ -> do + logInfo conf $ "Successfully updated ip address for " <> dom <> " to " <> pack (show rip) <> "." + return [rip] + threadDelay $ (confSleep conf) * 1000000 + check conf ip' + +setip :: Config -> IPv4 -> AttemptT IO [ChangeResourceRecordSetsResponse] +setip conf ip = do + liftIO $ logDebug conf $ "Attempt to set ip address to " <> pack (show ip) <> "." + let pause = confRetrySleep conf + rnum = confRetry conf + ret = Utils.retry pause rnum + awsconf = confAws conf + zid <- ret $ getZoneIdByName awsconf (confHostedZone conf) + liftIO $ logDebug conf $ "Route53 hosted zone: " <> pack (show zid) <> "." + response <- setARecordRetry pause rnum awsconf zid (confDomain conf) (confTtl conf) ip + return response + +-- -------------------------------------------------------------------------- -- +-- Main +-- + +-- | The main function +-- +-- * parses command line arguments, +-- * initializes devices for loggin and sets up the logging functions, +-- * configures the service, and +-- * runs the daemon. +-- +-- For help call the main program with '--help". +-- +main :: IO () +main = do + a <- cmdArgs dyndnsargs + + let execWithLogfile logfile = do + hSetBuffering logfile LineBuffering + + verb <- getVerbosity + + -- Initialize the boot logger: + let bootLoglevel = case verb of + Quiet -> Error + _ -> Aws.Debug + + let bootLogger = getLogger logfile bootLoglevel + bootLogger Info "\n=== Start r53-dyndns ===" + + -- Initialize the service logger: + let loglevel = case verb of + Quiet -> Error + Normal -> Warning + Loud -> Aws.Debug + + let logger = getLogger logfile loglevel + + -- Configure the service + when (let d = (hosted_zone a) in null d || last d /= '.') $ do + let err = "The domain name of a AWS Route53 must end with a DOT. Please provide a valid ABSOLUTE DNS domain name as hosted zone name." + logger Error err + error $ "FATAL ERROR: " <> (unpack err) + + let domain + | (subdomain a /= def) = Domain $ pack (subdomain a) <> "." <> pack (hosted_zone a) + | otherwise = Domain $ pack (hosted_zone a) + + awsConf <- awsConfiguration a logger + + let conf = Config + { confHostedZone = Domain . pack . hosted_zone $ a + , confDomain = domain + , confTtl = ttl a + , confSleep = sleep a + , confRetry = retry a + , confRetrySleep = retry_sleep a + , confAws = awsConf + , confLog = logger + } + + let dom = dText (confDomain conf) + hostedzone = dText (confHostedZone conf) + + -- Run the daemon + logInfo conf $ "Start r53-dyndns client for domain " <> dom <> " in hosted zone " <> hostedzone <> "." + daemon conf `finally` bootLogger Info "\n=== Exit r53-dyndns ===" + + if log_file a /= def + then withFile (log_file a) AppendMode execWithLogfile + else execWithLogfile stderr + diff --git a/aws.cabal b/aws.cabal index a3e48e1a..b4c1fef9 100644 --- a/aws.cabal +++ b/aws.cabal @@ -87,6 +87,18 @@ Library Aws.Ses.Commands, Aws.Ses.Commands.SendRawEmail, Aws.Ses.Core + 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 + -- Packages needed in order to build this package. Build-depends: attempt >= 0.3.1.1 && < 0.5, @@ -113,7 +125,8 @@ Library time >= 1.1.4 && < 1.5, transformers >= 0.2.2.0 && < 0.4, utf8-string == 0.3.*, - xml-conduit >= 1.0.1 && <1.1 + xml-conduit >= 1.0.1 && <1.1, + xml-hamlet >= 0.3.0 GHC-Options: -Wall @@ -129,7 +142,10 @@ Library OverloadedStrings, TupleSections, ScopedTypeVariables, - EmptyDataDecls + EmptyDataDecls, + GeneralizedNewtypeDeriving, + QuasiQuotes + -- Modules not exported by this package. -- Other-modules: diff --git a/ghci.hs b/ghci.hs index 6e17692c..edcb44e4 100644 --- a/ghci.hs +++ b/ghci.hs @@ -5,3 +5,4 @@ import qualified Aws.S3 as S3 import qualified Aws.SimpleDb as Sdb import qualified Aws.Sqs as Sqs import qualified Aws.Ses as Ses +import qualified Aws.Route53 as Route53