twiml-0.2.0.0: src/Text/XML/Twiml/Internal/Twiml.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-------------------------------------------------------------------------------
-- |
-- Module : Text.XML.Twiml.Internal.Twiml
-- Copyright : (C) 2014-15 Mark Andrus Roberts
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Mark Andrus Roberts <markandrusroberts@gmail.com>
-- Stability : provisional
--
-- This module defines all of the TwiML verbs and nouns in a single place
-- (mainly due to a few mutually-recursive definitions). This modules also
-- exposeses the internals of each TwiML's attributes.
--
-- Prefer the definitions re-exported by the
-- <Text-XML-Twiml.html Text.XML.Twiml> and
-- <Text-XML-Twiml-Verbs.html Text.XML.Twiml.Verbs> modules to those exported
-- here.
-------------------------------------------------------------------------------
module Text.XML.Twiml.Internal.Twiml
( -- * TwiML
MessagingTwiml(..)
, MessagingVerbsF(..)
, VoiceTwiml(..)
, VoiceVerbsF(..)
, Base
, IsTwimlLike
, TwimlLike
, TwimlLike'
, response
-- ** Nouns
, DialNoun(..)
, DialNounF(..)
-- *** Client
, Client
, ClientF(..)
, ClientAttributes(..)
-- *** Conference
, Conference
, ConferenceF(..)
, ConferenceAttributes(..)
-- *** Number
, Number
, NumberF(..)
, NumberAttributes(..)
-- *** Queue
, Queue
, QueueF(..)
, QueueAttributes(..)
-- *** Sip
, Sip
, SipF(..)
, SipAttributes(..)
-- ** Verbs
-- *** Dial
, Dial
, DialF(..)
, DialAttributes(..)
-- *** End
, End
, EndF(..)
-- *** Enqueue
, Enqueue
, EnqueueF(..)
, EnqueueAttributes(..)
-- *** Hangup
, Gather
, GatherF(..)
, GatherAttributes(..)
, Nest
, In
-- *** Hangup
, Hangup
, HangupF(..)
-- *** Leave
, Leave
, LeaveF(..)
-- *** Message
, Message
, MessageF(..)
, MessageAttributes(..)
-- *** Pause
, Pause
, PauseF(..)
, PauseAttributes(..)
-- *** Play
, Play
, PlayF(..)
, PlayAttributes(..)
-- *** Record
, Record
, RecordF(..)
, RecordAttributes(..)
-- *** Redirect
, Redirect
, RedirectF(..)
, RedirectAttributes(..)
-- *** Reject
, Reject
, RejectF(..)
, RejectAttributes(..)
-- *** Say
, Say
, SayF(..)
, SayAttributes(..)
-- *** Sms
, Sms
, SmsF(..)
, SmsAttributes(..)
) where
import Control.Monad
import Control.DeepSeq
import Data.Data
import Data.Default
import Data.Void
import GHC.Generics (Generic)
import Text.XML.Light
import Text.XML.Twiml.Internal
import Text.XML.Twiml.Internal.TH
import Text.XML.Twiml.Types
-------------------------------------------------------------------------------
-- Nouns
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Client
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Client
required
String
attributes
url, URL
method, Method
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Conference
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Conference
required
String
attributes
muted, Bool
beep, Bool
startOnEnter, Bool, startConferenceOnEnter
endOnExit, Bool, endConferenceOnExit
waitURL, URL
waitMethod, Method
maxParticipants, Natural
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Number
-------------------------------------------------------------------------------
type Digits = [Digit]
twimlSpecStringToData [s|
Number
required
String
attributes
sendDigits, Digits
url, URL
method, Method
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Queue
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Queue
required
String
attributes
url, URL
method, Method
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Sip
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Sip
required
URL
attributes
username, String
password, String
transport, Transport
headers, String
url, URL
method, Method
toXMLForGADT
toAttrsForAttributes
|]
data DialNoun = forall i. DialNoun (IxFree DialNounF i Void)
instance ToSomeNode DialNoun where
toSomeNode (DialNoun dialNoun) = SomeNode $ toXML dialNoun
instance ToSomeNode EitherDialNounString where
toSomeNode = either toSomeNode toSomeNode
instance ToXML DialNoun where
toXML (DialNoun dialNoun) = toXML dialNoun
instance Show DialNoun where
show = showDialNoun
showDialNoun :: DialNoun -> String
showDialNoun = concatMap ppElement . toXML
newtype DialNounF i a = DialNounF
{ getDialNounF ::
( ClientF i :+:
ConferenceF i :+:
NumberF i :+:
QueueF i :+:
SipF i ) a
} deriving (Functor, Generic, Show, Typeable)
instance (f i :<: ( ClientF i :+:
ConferenceF i :+:
NumberF i :+:
QueueF i :+:
SipF i )
) => f i :<: DialNounF i where
inj = DialNounF . inj
prj = prj . getDialNounF
instance Functor1 DialNounF where
fmap1 = fmap
instance Show1 DialNounF where
show1 = show
instance ToXML a => ToXML (DialNounF i a) where
toXML = toXML . getDialNounF
instance ToXML (IxFree DialNounF i Void) where
toXML (IxFree f) = toXML f
toXML _ = error "Impossible"
-------------------------------------------------------------------------------
-- Verbs
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Dial
-------------------------------------------------------------------------------
type EitherDialNounString = Either DialNoun String
twimlSpecStringToData [s|
Dial
required
EitherDialNounString
attributes
action, URL
method, Method
timeout, Natural
hangupOnStar, Bool
timeLimit, Natural
callerId, String
record', Bool, record
recursive
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- End
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
End
|]
instance ToXML (EndF i a) where
toXML EndF = []
-------------------------------------------------------------------------------
-- Enqueue
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Enqueue
required
String
attributes
action, URL
method, Method
waitURL, URL, waitUrl
waitMethod, Method, waitUrlMethod
recursive
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Hangup
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Hangup
toXMLForGADT
|]
-------------------------------------------------------------------------------
-- Leave
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Leave
toXMLForGADT
|]
-------------------------------------------------------------------------------
-- Message
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Message
required
String
attributes
to, String
from, String
action, URL
method, Method
statusCallback, URL
recursive
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Pause
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Pause
attributes
duration, Natural, length
recursive
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Play
-------------------------------------------------------------------------------
type MaybeURL = Maybe URL
twimlSpecStringToData [s|
Play
required
MaybeURL
attributes
loop, Natural
digits, Digits
recursive
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Record
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Record
attributes
action, URL
method, Method
timeout, Natural
finishOnKey, Key
maxLength, Natural
transcribe, Bool
transcribeCallback, URL
playBeep, Bool
recursive
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Redirect
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Redirect
required
URL
attributes
method, Method
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Reject
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Reject
attributes
reason, Reason
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Say
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Say
required
String
attributes
voice, Voice
loop, Natural
recursive
toXMLForGADT
|]
lang :: Voice -> Maybe (Either Lang LangAlice)
lang (Man l) = Left <$> l
lang (Woman l) = Left <$> l
lang (Alice r) = Right <$> r
instance ToAttrs SayAttributes where
toAttrs = flip makeAttrs
[ makeAttr "voice" _sayVoice
, makeAttr "loop" _sayLoop
, makeAttr' "language" (_sayVoice >=> lang) (either toAttrValue toAttrValue)
]
-------------------------------------------------------------------------------
-- Sms
-------------------------------------------------------------------------------
twimlSpecStringToData [s|
Sms
required
String
attributes
to, String
from, String
action, URL
method, Method
statusCallback, URL
recursive
toXMLForGADT
toAttrsForAttributes
|]
-------------------------------------------------------------------------------
-- Gather
-------------------------------------------------------------------------------
data Gather
data In
type family Nest a i b where
Nest i In Gather =
( Record ∉ i
, Gather ∉ i
, Sms ∉ i
, Dial ∉ i
, Enqueue ∉ i
, Leave ∉ i
, Hangup ∉ i
, Redirect ∉ i
, Reject ∉ i
)
data GatherF i a where
GatherF :: Nest i In Gather
=> GatherAttributes
-> IxFree VoiceVerbsF i Void
-> a
-> GatherF '[Gather] a
deriving instance Functor (GatherF i)
instance Functor1 GatherF where
fmap1 = fmap
deriving instance Show a => Show (GatherF i a)
instance ToXML a => ToXML (GatherF i a) where
toXML (GatherF attrs a b) = makeElement "Gather" (toXML a) (toAttrs attrs) : toXML b
-- | See <https://www.twilio.com/docs/api/twiml/gather#attributes>.
data GatherAttributes = GatherAttributes
{ _gatherAction :: Maybe URL
, _gatherMethod :: Maybe Method
, _gatherTimeout :: Maybe Natural
, _gatherFinishOnKey :: Maybe Key
, _gatherNumDigits :: Maybe Natural
} deriving (Data, Eq, Generic, NFData, Ord, Read, Show, Typeable)
instance Default GatherAttributes where
def = GatherAttributes
{ _gatherAction = def
, _gatherMethod = def
, _gatherTimeout = def
, _gatherFinishOnKey = def
, _gatherNumDigits = def
}
instance ToAttrs GatherAttributes where
toAttrs = flip makeAttrs
[ makeAttr "action" _gatherAction
, makeAttr "method" _gatherMethod
, makeAttr "timeout" _gatherTimeout
, makeAttr "finishOnKey" _gatherFinishOnKey
, makeAttr "numDigits" _gatherNumDigits
]
-------------------------------------------------------------------------------
-- TwiML
-------------------------------------------------------------------------------
data VoiceTwiml = forall i. VoiceTwiml (IxFree VoiceVerbsF i Void)
instance ToElement VoiceTwiml where
toElement (VoiceTwiml twiml) = unode "Response" $ toXML twiml
instance Show VoiceTwiml where
show = showTwiml
showTwiml :: VoiceTwiml -> String
showTwiml twiml = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++ ppElement (toElement twiml) ++ "\n"
newtype VoiceVerbsF i a = VoiceVerbsF
{ getVoiceVerbsF ::
( SayF i :+:
PlayF i :+:
GatherF i :+:
SmsF i :+: -- Shared between Voice and Messaging TwiML
DialF i :+:
EnqueueF i :+:
LeaveF i :+:
HangupF i :+:
RecordF i :+:
RedirectF i :+: -- Shared between Voice and Messaging TwiML
RejectF i :+:
PauseF i :+:
EndF i ) a -- Shared between Voice and Messaging TwiML
} deriving (Functor, Generic, Show, Typeable)
instance (f i :<: ( SayF i :+:
PlayF i :+:
GatherF i :+:
SmsF i :+:
DialF i :+:
EnqueueF i :+:
LeaveF i :+:
HangupF i :+:
RecordF i :+:
RedirectF i :+:
RejectF i :+:
PauseF i :+:
EndF i )
) => f i :<: VoiceVerbsF i where
inj = VoiceVerbsF . inj
prj = prj . getVoiceVerbsF
instance Functor1 VoiceVerbsF where
fmap1 = fmap
instance Show1 VoiceVerbsF where
show1 = show
instance ToXML a => ToXML (VoiceVerbsF i a) where
toXML = toXML . getVoiceVerbsF
instance ToXML (IxFree VoiceVerbsF i Void) where
toXML (IxFree f) = toXML f
toXML _ = error "Impossible"
data MessagingTwiml = forall i. MessagingTwiml (IxFree MessagingVerbsF i Void)
instance ToElement MessagingTwiml where
toElement (MessagingTwiml twiml) = unode "Response" $ toXML twiml
instance Show MessagingTwiml where
show = showMessagingTwiml
showMessagingTwiml :: MessagingTwiml -> String
showMessagingTwiml twiml = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++ ppElement (toElement twiml) ++ "\n"
newtype MessagingVerbsF i a = MessagingVerbsF
{ getMessagingVerbsF ::
( MessageF i :+:
RedirectF i :+: -- Shared between Voice and Messaging TwiML
SmsF i :+: -- Shared between Voice and Messaging TwiML
EndF i ) a -- Shared between Voice and Messaging TwiML
} deriving (Functor, Generic, Show, Typeable)
instance (f i :<: ( MessageF i :+:
RedirectF i :+:
SmsF i :+:
EndF i )
) => f i :<: MessagingVerbsF i where
inj = MessagingVerbsF . inj
prj = prj . getMessagingVerbsF
instance Functor1 MessagingVerbsF where
fmap1 = fmap
instance Show1 MessagingVerbsF where
show1 = show
instance ToXML a => ToXML (MessagingVerbsF i a) where
toXML = toXML . getMessagingVerbsF
instance ToXML (IxFree MessagingVerbsF i Void) where
toXML (IxFree f) = toXML f
toXML _ = error "Impossible"
-- | 'Base' maps the empty data declaration for a TwiML verb to its
-- corresponding base functor.
type family Base d where
Base Dial = DialF
Base End = EndF
Base Enqueue = EnqueueF
Base Gather = GatherF
Base Hangup = HangupF
Base Leave = LeaveF
Base Message = MessageF
Base Pause = PauseF
Base Play = PlayF
Base Record = RecordF
Base Redirect = RedirectF
Base Reject = RejectF
Base Say = SayF
Base Sms = SmsF
Base Client = ClientF
Base Conference = ConferenceF
Base Number = NumberF
Base Queue = QueueF
Base Sip = SipF
type IsTwimlLike f i = (Functor1 f, (Base i) '[i] :<: f '[i])
type TwimlLike f i = TwimlLike' f '[i]
type TwimlLike' f = IxFree f
response :: IxFree VoiceVerbsF i Void -> VoiceTwiml
response = VoiceTwiml