{-# LANGUAGE CPP #-}
{-# 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
#if __GLASGOW_HASKELL__ < 710
import           Data.Monoid
#endif
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)
#if MIN_VERSION_time(1,5,0)
import           Data.Time.Format          (parseTimeM, defaultTimeLocale)
#else
import           Data.Time.Format          (parseTime)
import           System.Locale             (defaultTimeLocale)
#endif
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 "<none>" 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|
    <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

-- -------------------------------------------------------------------------- --
-- 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|
    <Name>#{dText rrsName}
    <Type>#{typeToText rrsType}
    $maybe a <- rrsAliasTarget
      ^{[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}
    $if not (null rrsRecords)
      <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

-- 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
#if MIN_VERSION_time(1,5,0)
    utcTime str = fromJust $ parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" str
#else
    utcTime str = fromJust $ parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" str
#endif

-- -------------------------------------------------------------------------- --
-- 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