├── Setup.hs ├── test ├── Spec.hs ├── Data │ ├── TransientStoreMemoryTest.hs │ └── TransientStoreSpec.hs ├── Twilio │ ├── KeySpec.hs │ └── IVRSpec.hs └── Network │ └── Wai │ └── Twilio │ └── RequestValidatorMiddlewareSpec.hs ├── .gitattributes ├── src ├── Examples │ ├── EX1.hs │ ├── EX2.hs │ ├── Main.hs │ └── EX3.hs ├── Twilio │ ├── Key.hs │ └── IVR.hs ├── Network │ └── Wai │ │ └── Twilio │ │ ├── RequestValidatorMiddleware.hs │ │ └── IVR.hs └── Data │ └── TransientStore.hs ├── LICENSE ├── README.md └── twilio-ivr.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -- see https://github.com/hspec/hspec-example/blob/master/strip.cabal 3 | -- runhaskell -isrc -itest test/Spec.hs -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | 7 | # Standard to msysgit 8 | *.doc diff=astextplain 9 | *.DOC diff=astextplain 10 | *.docx diff=astextplain 11 | *.DOCX diff=astextplain 12 | *.dot diff=astextplain 13 | *.DOT diff=astextplain 14 | *.pdf diff=astextplain 15 | *.PDF diff=astextplain 16 | *.rtf diff=astextplain 17 | *.RTF diff=astextplain 18 | -------------------------------------------------------------------------------- /src/Examples/EX1.hs: -------------------------------------------------------------------------------- 1 | module Examples.EX1 where 2 | 3 | import Control.Lens 4 | import Control.Lens.Setter 5 | import Control.Monad (void) 6 | import Control.Monad.Trans.Class (lift) 7 | 8 | import Data.List (intersperse) 9 | 10 | import Twilio.IVR 11 | 12 | 13 | simple :: Call -> TwilioIVRCoroutine () 14 | simple call = do 15 | say $ "hello to you " ++ (intersperse ' ' $ call ^. Twilio.IVR.from) 16 | num <- gather "Please enter your five digit sign in code" (numDigits .~ 5) 17 | let ok = num == (read "12345") 18 | say "Please wait" 19 | say "While we process your request" 20 | -- We can do some IO, like if you need to read from a database 21 | lift $ print ok 22 | if ok then say "You've signed in correctly!" else say "We were unable to verify your account" 23 | -------------------------------------------------------------------------------- /test/Data/TransientStoreMemoryTest.hs: -------------------------------------------------------------------------------- 1 | -- runhaskell -isrc test/Data/TransientStoreMemoryTest.hs 2 | -- ghc -isrc test/Data/TransientStoreMemoryTest.hs -o memtest 3 | module Main where 4 | 5 | import Control.Concurrent 6 | import Control.Parallel.Strategies 7 | 8 | import Data.TransientStore 9 | 10 | 11 | -- adds 10 entries per second, should equalize at 10 entries total since they live 1 second 12 | accumNoPop db = do 13 | let val = show [1..100000] 14 | insert db (val `using` rdeepseq) 15 | threadDelay 100000 16 | accumNoPop db 17 | 18 | 19 | addPop db = do 20 | let val = show [1..100000] 21 | key <- insert db (val `using` rdeepseq) 22 | threadDelay 100000 23 | pop db key 24 | addPop db 25 | 26 | main = do 27 | putStrLn "Begin" 28 | db <- create 1 :: IO (TransientStore String) 29 | forkIO (accumNoPop db) 30 | forkIO (addPop db) 31 | putStrLn "Press key to end" 32 | getChar 33 | putStrLn "Ended" -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Steve Kollmansberger 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Twilio IVR 2 | 3 | A fluent Twilio IVR library for Haskell. 4 | 5 | IVR with Twilio can be very painful, since every interaction cycle requires a discrete 6 | request/response. This may be implemented using a separate web method for each possible 7 | stage in a conversation. Tracking state during a call is also problematic for the same reason. 8 | This library introduces a coroutine-based monad for Twilio IVR which makes extended 9 | interactions and state maintenance as seamless as console I/O. 10 | 11 | The module requires wai for web services, but can work with any wai handler, such as the Warp server 12 | or as a FastCGI process on a shared server. 13 | 14 | See examples folder. 15 | 16 | Note: The Call data and Twilio methods still need to be fleshed out. They exist in a bare bones or proof of concept form. 17 | 18 | ```hs 19 | simple :: Call -> TwilioIVRCoroutine () 20 | simple call = do 21 | say $ "hello to you " ++ (intersperse ' ' $ call ^. Twilio.IVR.from) 22 | num <- gather "Please enter your five digit sign in code" (numDigits .~ 5) 23 | let ok = num == "12345" 24 | say "Please wait" 25 | say "While we process your request" 26 | -- We can do some IO, like if you need to read from a database 27 | lift $ print ok 28 | if ok then say "You've signed in correctly!" else say "We were unable to verify your account" 29 | ``` 30 | -------------------------------------------------------------------------------- /test/Twilio/KeySpec.hs: -------------------------------------------------------------------------------- 1 | module Twilio.KeySpec where 2 | 3 | import Test.Hspec 4 | import Twilio.Key 5 | 6 | 7 | ks = "0123456789#*" 8 | kss = map (:[]) ks 9 | 10 | kk = [K0, K1, K2, K3, K4, K5, K6, K7, K8, K9, KPound, KStar] 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "read" $ do 15 | it "read individual keys" $ do 16 | mapM_ (\(x,y) -> read x `shouldBe` y) (zip kss kk) 17 | it "reads key list" $ do 18 | read ks `shouldBe` kk 19 | describe "show" $ do 20 | it "shows individual keys" $ do 21 | mapM_ (\(x,y) -> show x `shouldBe` y) (zip kk kss) 22 | it "shows key list" $ do 23 | show kk `shouldBe` ks 24 | describe "keyToLetter" $ do 25 | it "converts alpha keys to letters" $ do 26 | keyToLetter K3 `shouldBe` "DEF" 27 | keyToLetter K7 `shouldBe` "PQRS" 28 | it "converts non-alpha keys to empty list" $ do 29 | keyToLetter K0 `shouldBe` "" 30 | keyToLetter K1 `shouldBe` "" 31 | describe "letterToKey" $ do 32 | it "converts alpha letters to key" $ do 33 | letterToKey 'E' `shouldBe` (Just K3) 34 | letterToKey 'u' `shouldBe` (Just K8) 35 | it "converts numbers to key" $ do 36 | letterToKey '1' `shouldBe` (Just K1) 37 | letterToKey '5' `shouldBe` (Just K5) 38 | it "converts non-alpha letters to nothing" $ do 39 | letterToKey '+' `shouldBe` Nothing 40 | -------------------------------------------------------------------------------- /src/Examples/EX2.hs: -------------------------------------------------------------------------------- 1 | module Examples.EX2 where 2 | 3 | import Control.Lens 4 | import Control.Lens.Setter 5 | import Control.Monad (void) 6 | import Control.Monad.Trans.Class (lift) 7 | 8 | import Data.List (intersperse) 9 | import Data.Time.LocalTime 10 | 11 | import Twilio.IVR 12 | 13 | data User = User { 14 | uid :: String, 15 | name :: String, 16 | balance :: Int 17 | } 18 | 19 | users = [ 20 | User "1234" "Joe Smith" 150, 21 | User "2525" "Jane Doe" 267, 22 | User "4321" "Linda Doe" 350 23 | ] 24 | 25 | -- Can use functions that return values in the monad 26 | -- they do not need to include or terminate in a "gather" 27 | -- they can also be recursive 28 | signin :: TwilioIVRCoroutine User 29 | signin = do 30 | eid <- gather "Please enter your account id" (numDigits .~ 4) 31 | case filter (\u -> read (uid u) == eid) users of 32 | [] -> do 33 | say "Sorry, we don't recognize that id, please try again." 34 | signin 35 | [u] -> do 36 | say $ "Welcome " ++ (name u) 37 | return u 38 | 39 | account :: Call -> TwilioIVRCoroutine () 40 | account call = do 41 | -- work in the IO monad 42 | (ZonedTime (LocalTime _ timeOfDay) _) <- lift getZonedTime 43 | let hours = todHour timeOfDay 44 | say $ "Good " ++ if (hours < 12) then "morning" 45 | else if (hours < 20) then "afternoon" 46 | else "evening" 47 | user <- signin 48 | say $ "Your account balance is " ++ (show $ balance user) 49 | hangup -- Not actually needed 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /src/Examples/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} 2 | module Main where 3 | 4 | import Control.Applicative 5 | 6 | import qualified Examples.EX1 as EX1 7 | import qualified Examples.EX2 as EX2 8 | import qualified Examples.EX3 as EX3 9 | 10 | import qualified Data.TransientStore as TS 11 | 12 | import Network.Wai 13 | import qualified Network.Wai.Handler.Warp as Warp (run) 14 | import qualified Network.Wai.Handler.FastCGI as FCGI (run) 15 | import Network.Wai.Middleware.Approot 16 | import Network.Wai.Middleware.Routes 17 | import Network.Wai.Twilio.IVR 18 | import Network.Wai.Twilio.RequestValidatorMiddleware 19 | 20 | import Twilio.IVR 21 | 22 | 23 | getTIVRSubRoute :: (Call -> TwilioIVRCoroutine ()) -> MyRoute -> TIVRSubRoute 24 | getTIVRSubRoute entry (MyRoute db) = TIVRSubRoute db entry 25 | 26 | example1Route = getTIVRSubRoute EX1.simple 27 | example2Route = getTIVRSubRoute EX2.account 28 | example3Route = getTIVRSubRoute EX3.search 29 | 30 | data MyRoute = MyRoute TIVRDB 31 | 32 | 33 | mkRoute "MyRoute" [parseRoutes| 34 | /ex1 Example1 TIVRSubRoute example1Route 35 | /ex2 Example2 TIVRSubRoute example2Route 36 | /ex3 Example3 TIVRSubRoute example3Route 37 | |] 38 | 39 | 40 | prepareApp :: IO Application 41 | prepareApp = do 42 | db <- TS.create 120 43 | return $ waiApp $ route $ MyRoute db 44 | 45 | 46 | dev :: IO () 47 | dev = do 48 | print "http://localhost:8080/" 49 | prepareApp >>= Warp.run 8080 50 | 51 | main :: IO () 52 | main = hardcoded "/test/ivr-examples.fcgi" <$> 53 | {-- requestValidator "..." <$> --} 54 | prepareApp >>= FCGI.run 55 | 56 | -------------------------------------------------------------------------------- /test/Network/Wai/Twilio/RequestValidatorMiddlewareSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Network.Wai.Twilio.RequestValidatorMiddlewareSpec where 3 | 4 | 5 | import Test.Hspec 6 | 7 | import Network.Wai.Twilio.RequestValidatorMiddleware 8 | 9 | import qualified Data.ByteString.Char8 as S8 10 | import qualified Data.ByteString.Lazy as BL 11 | 12 | import Network.HTTP.Types 13 | import Network.Wai 14 | import Network.Wai.Test 15 | 16 | 17 | trivialApp :: Application 18 | trivialApp req f = 19 | f $ 20 | responseLBS 21 | ok200 22 | [ ("content-type", "text/plain") ] 23 | "Trivial App" 24 | 25 | -- https://mycompany.com/myapp.php?foo=1&bar=2 26 | req1 = SRequest defaultRequest 27 | { requestMethod = "POST" 28 | , rawPathInfo = "/myapp.php" 29 | , rawQueryString = "?foo=1&bar=2" 30 | , isSecure = True 31 | , requestHeaderHost = Just "mycompany.com" 32 | , requestHeaders = [("X-Twilio-Signature", "RSOYDt4T1cUTdK1PDd93/VVr8B8=")] 33 | } "Digits=1234&To=%2B18005551212&From=%2B14158675309&Caller=%2B14158675309&CallSid=CA1234567890ABCDE" 34 | 35 | 36 | spec :: Spec 37 | spec = do 38 | describe "requestValidator" $ do 39 | it "validates correct requests" $ do 40 | (SResponse status _ msg) <- runSession (srequest req1) (requestValidator "12345" trivialApp) 41 | msg `shouldBe` "Trivial App" 42 | status `shouldBe` ok200 43 | it "rejects incorrect requests" $ do 44 | (SResponse status _ msg) <- runSession (srequest req1) (requestValidator "1234" trivialApp) 45 | msg `shouldBe` "Invalid X-Twilio-Signature" 46 | status `shouldBe` unauthorized401 47 | 48 | 49 | 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /src/Examples/EX3.hs: -------------------------------------------------------------------------------- 1 | module Examples.EX3 where 2 | 3 | import Control.Lens 4 | import Control.Lens.Setter 5 | import Control.Monad (void) 6 | import Control.Monad.Trans.Class (lift) 7 | 8 | import Data.List (intersperse, isPrefixOf) 9 | import Data.Time.LocalTime 10 | import Data.Maybe (catMaybes) 11 | 12 | import Twilio.Key 13 | import Twilio.IVR 14 | 15 | data User = User { 16 | lastname :: String, 17 | firstname :: String, 18 | extension :: Maybe String 19 | } 20 | deriving (Show) 21 | 22 | users = [ 23 | User "Smith" "Joe" $ Just "7734", 24 | User "Doe" "Jane" $ Just "1556", 25 | User "Doe" "Linda" Nothing, 26 | User "Samson" "Tina" $ Just "3443", 27 | User "O'Donald" "Jack" $ Just "5432", 28 | User "Sam-son" "Tony" $ Nothing 29 | ] 30 | 31 | -- | match last name by removing non-keypad characters 32 | matchingUsers :: [User] -> [Key] -> [User] 33 | matchingUsers ux kx = filter (\u -> let lnky = catMaybes $ map letterToKey (lastname u) in 34 | isPrefixOf kx lnky) ux 35 | 36 | 37 | describeUser :: User -> TwilioIVRCoroutine () 38 | describeUser u = do 39 | say (firstname u) 40 | say (lastname u) 41 | case extension u of 42 | (Just x) -> say $ "Phone extension " ++ (intersperse ' ' x) 43 | Nothing -> return () 44 | 45 | 46 | search :: Call -> TwilioIVRCoroutine () 47 | search _ = do 48 | say "Welcome." 49 | name <- gather "Please enter the last name of the person you wish to find. You do not have to enter the entire name. Finish with the pound key." 50 | ((finishOnKey .~ Just KPound).(timeout .~ 30)) 51 | case matchingUsers users name of 52 | [] -> say "Sorry, no matching results found." 53 | [x] -> describeUser x 54 | xs -> do 55 | say $ "We found "++(show $ length xs)++" matching users." 56 | mapM_ describeUser xs 57 | say "Have a nice day." 58 | -------------------------------------------------------------------------------- /test/Twilio/IVRSpec.hs: -------------------------------------------------------------------------------- 1 | module Twilio.IVRSpec where 2 | 3 | import Test.Hspec 4 | 5 | import Twilio.IVR 6 | 7 | 8 | import Control.Lens 9 | import Control.Lens.Setter 10 | 11 | import Control.Monad.Coroutine 12 | import Control.Monad.Coroutine.SuspensionFunctors 13 | import Text.XML.Light 14 | 15 | -- never use for production purposes, NOT TRUE XML EQUIVALENCE 16 | instance Eq Content where 17 | x == y = (showContent x) == (showContent y) 18 | 19 | spec :: Spec 20 | spec = do 21 | describe "say" $ do 22 | it "generates data structure" $ do 23 | Left (Request res _) <- resume (say "Test Message") 24 | res `shouldBe` (Right (Say "Test Message")) 25 | it "generates XML" $ do 26 | Left (Request res _) <- resume (say "Test Message") 27 | renderTwiML res `shouldBe` (Elem $ unode "Say" "Test Message") 28 | describe "hangup" $ do 29 | it "generates data structure" $ do 30 | Left (Request res _) <- resume hangup 31 | res `shouldBe` (Right Hangup) 32 | it "generates XML" $ do 33 | Left (Request res _) <- resume hangup 34 | renderTwiML res `shouldBe` (Elem $ unode "Hangup" ()) 35 | describe "gather" $ do 36 | it "generates XML" $ do 37 | Left (Request res _) <- resume (gather "Test Message" (numDigits .~ 10)) 38 | renderTwiML res `shouldBe` (Elem $ unode "Gather" (Elem $ unode "Say" "Test Message") & 39 | add_attrs [ 40 | Attr (unqual "timeout") "5", 41 | Attr (unqual "finishOnKey") "#", 42 | Attr (unqual "numDigits") "10", 43 | Attr (unqual "method") "POST", 44 | Attr (unqual "action") "" ]) 45 | Left (Request res2 _) <- resume (gather "Test Message" ( 46 | (numDigits .~ 5) . 47 | (timeout .~ 10) . 48 | (finishOnKey .~ Nothing) 49 | )) 50 | renderTwiML res2 `shouldBe` (Elem $ unode "Gather" (Elem $ unode "Say" "Test Message") & 51 | add_attrs [ 52 | Attr (unqual "timeout") "10", 53 | Attr (unqual "finishOnKey") "", 54 | Attr (unqual "numDigits") "5", 55 | Attr (unqual "method") "POST", 56 | Attr (unqual "action") "" ]) 57 | 58 | -------------------------------------------------------------------------------- /src/Twilio/Key.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-| 3 | Module : Twilio.Key 4 | Description : Keys used for Twilio phone IVR 5 | Copyright : (c) 2015 Steve Kollmansberger 6 | Maintainer : steve@kolls.net 7 | Stability : experimental 8 | 9 | Basic representation, including read and show, for digits (0-9), star, and pound. 10 | -} 11 | module Twilio.Key (Key(..), letterToKey, keyToLetter) where 12 | 13 | import Control.Applicative 14 | import Data.Char (toUpper) 15 | import Data.List 16 | import Text.Read (readMaybe) 17 | 18 | -- | A physical phone key which can be received from a gather 19 | data Key 20 | = K0 -- ^ 0 21 | | K1 -- ^ 1 22 | | K2 -- ^ 2 23 | | K3 -- ^ 3 24 | | K4 -- ^ 4 25 | | K5 -- ^ 5 26 | | K6 -- ^ 6 27 | | K7 -- ^ 7 28 | | K8 -- ^ 8 29 | | K9 -- ^ 9 30 | | KStar -- ^ \* 31 | | KPound -- ^ # 32 | deriving (Eq) 33 | 34 | instance Show Key where 35 | show K0 = "0" 36 | show K1 = "1" 37 | show K2 = "2" 38 | show K3 = "3" 39 | show K4 = "4" 40 | show K5 = "5" 41 | show K6 = "6" 42 | show K7 = "7" 43 | show K8 = "8" 44 | show K9 = "9" 45 | show KStar = "*" 46 | show KPound = "#" 47 | showList kx xs = concatMap show kx++xs 48 | 49 | 50 | readKeyList :: String -> [Key] 51 | readKeyList = map (read.(:[])) 52 | 53 | 54 | instance Read Key where 55 | readsPrec _ "0" = [(K0, "")] 56 | readsPrec _ "1" = [(K1, "")] 57 | readsPrec _ "2" = [(K2, "")] 58 | readsPrec _ "3" = [(K3, "")] 59 | readsPrec _ "4" = [(K4, "")] 60 | readsPrec _ "5" = [(K5, "")] 61 | readsPrec _ "6" = [(K6, "")] 62 | readsPrec _ "7" = [(K7, "")] 63 | readsPrec _ "8" = [(K8, "")] 64 | readsPrec _ "9" = [(K9, "")] 65 | readsPrec _ "*" = [(KStar, "")] 66 | readsPrec _ "#" = [(KPound, "")] 67 | readsPrec _ _ = [] 68 | readList kx = [(readKeyList kx, [])] 69 | 70 | 71 | letterMapping = [ 72 | (K2, "ABC"), 73 | (K3, "DEF"), 74 | (K4, "GHI"), 75 | (K5, "JKL"), 76 | (K6, "MNO"), 77 | (K7, "PQRS"), 78 | (K8, "TUV"), 79 | (K9, "WXYZ")] 80 | 81 | 82 | -- | Given a character, converts it to a key symbol. Not case sensitive. 83 | letterToKey :: Char -> Maybe Key 84 | letterToKey c = case readMaybe [c] of 85 | (Just k) -> Just k 86 | _ -> fst <$> find (\(_, lx) -> elem (toUpper c) lx) letterMapping 87 | 88 | -- | Given a Key, returns all letter characters associated with it. 89 | keyToLetter :: Key -> [Char] 90 | keyToLetter k = case find (\(ke, _) -> k == ke) letterMapping of 91 | (Just (_, lx)) -> lx 92 | Nothing -> [] 93 | -------------------------------------------------------------------------------- /twilio-ivr.cabal: -------------------------------------------------------------------------------- 1 | name: twilio-ivr 2 | 3 | -- The package version. See the Haskell package versioning policy (PVP) 4 | -- for standards guiding when and how versions should be incremented. 5 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 6 | -- PVP summary: +-+------- breaking API changes 7 | -- | | +----- non-breaking API additions 8 | -- | | | +--- code changes with no API change 9 | version: 0.1.0.0 10 | 11 | 12 | synopsis: Fluent coroutine monad for interactive voice applications with Twilio 13 | 14 | -- A longer description of the package. 15 | -- description: 16 | 17 | 18 | homepage: https://github.com/steven777400/TwilioIVR 19 | license: MIT 20 | license-file: LICENSE 21 | author: Steve Kollmansberger 22 | maintainer: steve@kolls.net 23 | 24 | category: Web 25 | build-type: Simple 26 | 27 | -- Extra files to be distributed with the package, such as examples or a 28 | -- README. 29 | -- extra-source-files: 30 | 31 | 32 | cabal-version: >=1.10 33 | 34 | library 35 | -- Modules exported by the library. 36 | exposed-modules: Twilio.IVR, Twilio.Key, Data.TransientStore, Network.Wai.Twilio.IVR, Network.Wai.Twilio.RequestValidatorMiddleware 37 | 38 | -- Modules included in this library but not exported. 39 | -- other-modules: 40 | 41 | other-extensions: TemplateHaskell, OverloadedStrings, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns, FlexibleInstances 42 | build-depends: base ==4.*, cryptohash == 0.11.*, base64-bytestring == 1.0.*, bytestring == 0.10.*, uuid >=1.3 && <1.4, lens >=4.13 && <4.14, monad-coroutine >=0.9 && <0.10, transformers >=0.4 && <0.5, xml >=1.3 && <1.4, unordered-containers >=0.2 && <0.3, time >=1.5 && <1.6, random >=1.1 && <1.2, wai >=3.0 && <3.1, wai-routes >=0.9 && <0.10, wai-extra >= 3.0 && < 3.1, text >=1.2 && <1.3, http-types >=0.8 && <0.9, path-pieces >=0.2 && <0.3 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | 46 | test-suite spec 47 | type: exitcode-stdio-1.0 48 | ghc-options: -Wall 49 | hs-source-dirs: test 50 | main-is: Spec.hs 51 | build-depends: twilio-ivr, base == 4.*, hspec == 2.*, wai-extra, 52 | cryptohash == 0.11.*, base64-bytestring == 1.0.*, bytestring == 0.10.*, uuid >=1.3 && <1.4, lens >=4.13 && <4.14, monad-coroutine >=0.9 && <0.10, transformers >=0.4 && <0.5, xml >=1.3 && <1.4, unordered-containers >=0.2 && <0.3, time >=1.5 && <1.6, random >=1.1 && <1.2, wai >=3.0 && <3.1, wai-routes >=0.9 && <0.10, text >=1.2 && <1.3, http-types >=0.8 && <0.9, path-pieces >=0.2 && <0.3 53 | default-language: Haskell2010 54 | 55 | executable ivr-examples 56 | main-is: Examples/Main.hs 57 | hs-source-dirs: src 58 | build-depends: twilio-ivr, base == 4.*, 59 | warp, wai-handler-fastcgi, 60 | cryptohash == 0.11.*, base64-bytestring == 1.0.*, bytestring == 0.10.*, uuid >=1.3 && <1.4, lens >=4.13 && <4.14, monad-coroutine >=0.9 && <0.10, transformers >=0.4 && <0.5, xml >=1.3 && <1.4, unordered-containers >=0.2 && <0.3, time >=1.5 && <1.6, random >=1.1 && <1.2, wai >=3.0 && <3.1, wai-routes >=0.9 && <0.10, wai-extra >= 3.0 && < 3.1, text >=1.2 && <1.3, http-types >=0.8 && <0.9, path-pieces >=0.2 && <0.3 61 | default-language: Haskell2010 62 | 63 | -------------------------------------------------------------------------------- /test/Data/TransientStoreSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.TransientStoreSpec where 2 | 3 | import Test.Hspec 4 | import Data.TransientStore 5 | 6 | import Control.Concurrent 7 | import Data.UUID 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "peek" $ do 12 | it "returns Nothing if db is empty" $ do 13 | db <- create 5 :: IO (TransientStore String) 14 | peek db nil `shouldReturn` Nothing 15 | it "returns Nothing if key not in db" $ do 16 | db <- create 5 :: IO (TransientStore String) 17 | insert db "hello" 18 | result <- peek db nil 19 | result `shouldBe` Nothing 20 | it "returns the value if key in db" $ do 21 | db <- create 5 :: IO (TransientStore String) 22 | key <- insert db "hello" 23 | result <- peek db key 24 | result `shouldBe` (Just "hello") 25 | it "returns the value multiple times" $ do 26 | db <- create 5 :: IO (TransientStore String) 27 | key <- insert db "hello" 28 | result <- peek db key 29 | result `shouldBe` (Just "hello") 30 | result2 <- peek db key 31 | result2 `shouldBe` (Just "hello") 32 | it "returns the value if key one of several in db" $ do 33 | db <- create 5 :: IO (TransientStore String) 34 | key1 <- insert db "hello" 35 | key2 <- insert db "different" 36 | key1 `shouldNotBe` key2 37 | result1 <- peek db key1 38 | result1 `shouldBe` (Just "hello") 39 | result2 <- peek db key2 40 | result2 `shouldBe` (Just "different") 41 | 42 | describe "pop" $ do 43 | it "returns a value once only" $ do 44 | db <- create 5 :: IO (TransientStore String) 45 | key <- insert db "hello" 46 | result <- pop db key 47 | result `shouldBe` (Just "hello") 48 | result2 <- pop db key 49 | result2 `shouldBe` Nothing 50 | 51 | describe "cleanIfNeeded" $ do 52 | it "should not remove a value after a short time" $ do 53 | db <- create 1 :: IO (TransientStore String) 54 | key <- insert db "hello" 55 | threadDelay 500000 56 | result <- pop db key 57 | result `shouldBe` (Just "hello") 58 | it "should remove a value after a long time, but leave shorter values" $ do 59 | db <- create 1 :: IO (TransientStore String) 60 | key <- insert db "hello" 61 | key3 <- insert db "xyzzy" 62 | threadDelay 500000 63 | result <- peek db key 64 | result `shouldBe` (Just "hello") 65 | key2 <- insert db "different" 66 | threadDelay 900000 67 | result3 <- peek db key3 68 | result3 `shouldBe` Nothing 69 | result2' <- peek db key2 70 | result2' `shouldBe` (Just "different") 71 | threadDelay 2000000 72 | result' <- peek db key 73 | result' `shouldBe` Nothing 74 | result2' <- peek db key2 75 | result2' `shouldBe` Nothing 76 | it "should keep peek'd values alive" $ do 77 | db <- create 1 :: IO (TransientStore String) 78 | key1 <- insert db "hello" 79 | key2 <- insert db "there" 80 | threadDelay 500000 81 | result1 <- peek db key1 82 | result1 `shouldBe` (Just "hello") 83 | result2 <- peek db key2 84 | result2 `shouldBe` (Just "there") 85 | threadDelay 500000 86 | result1 <- peek db key1 87 | result1 `shouldBe` (Just "hello") 88 | threadDelay 500000 89 | result1 <- peek db key1 90 | result1 `shouldBe` (Just "hello") 91 | threadDelay 500000 92 | result1 <- peek db key1 93 | result1 `shouldBe` (Just "hello") 94 | threadDelay 500000 95 | result1 <- peek db key1 96 | result1 `shouldBe` (Just "hello") 97 | result2 <- peek db key2 98 | result2 `shouldBe` Nothing 99 | 100 | 101 | 102 | 103 | -------------------------------------------------------------------------------- /src/Network/Wai/Twilio/RequestValidatorMiddleware.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Module : Network.Wai.Twilio.RequestValidatorMiddleware 4 | Description : A wai middleware for validating incoming Twilio requests 5 | Copyright : (c) 2015 Steve Kollmansberger 6 | Maintainer : steve@kolls.net 7 | Stability : experimental 8 | 9 | See https://www.twilio.com/docs/security for details. Twilio includes an X-Twilio-Signature 10 | in each request, signing the request using your API auth token. 11 | -} 12 | module Network.Wai.Twilio.RequestValidatorMiddleware (requestValidator) where 13 | 14 | import qualified Crypto.MAC.HMAC as HMAC 15 | import qualified Crypto.Hash.SHA1 as SHA1 16 | 17 | import qualified Data.ByteString as B 18 | import qualified Data.ByteString.Char8 as BC 19 | import qualified Data.ByteString.Lazy as BL 20 | import Data.ByteString.Builder 21 | import Data.ByteString.Base64 22 | import Data.List 23 | import Data.Monoid 24 | import Data.IORef 25 | 26 | import Network.HTTP.Types 27 | import Network.Wai 28 | import Network.Wai.Middleware.Approot 29 | 30 | url :: B.ByteString -> Request -> Builder 31 | url approot r = "http" <> 32 | (if isSecure r then "s" else "") <> 33 | "://" <> 34 | (byteString $ maybe "" id (requestHeaderHost r)) <> 35 | (byteString approot) <> 36 | (byteString $ rawPathInfo r) <> 37 | (byteString $ rawQueryString r) 38 | 39 | -- load request bytestring using Wai strictRequestBody 40 | postParams :: B.ByteString -> Builder 41 | postParams r = foldl (<>) "" stringified 42 | where 43 | ordered = sortBy (\a b -> compare (fst a) (fst b)) (parseQuery r) 44 | stringified = map (\(k, mv) -> byteString k <> (byteString $ maybe "" id mv)) ordered 45 | 46 | 47 | hmacsha1 = HMAC.hmac SHA1.hash 64 48 | 49 | signature :: B.ByteString -> Builder -> B.ByteString 50 | signature authtoken contents = encode $ hmacsha1 authtoken rbs 51 | where rbs = BL.toStrict $ toLazyByteString contents 52 | 53 | calcSignature :: B.ByteString -> Request -> B.ByteString -> B.ByteString 54 | calcSignature authtoken r rb = let 55 | rootUrl = maybe "" id (getApprootMay r) 56 | url' = url rootUrl r 57 | requestbody' = case requestMethod r of 58 | "POST" -> postParams rb 59 | _ -> "" 60 | in 61 | signature authtoken (url' <> requestbody') 62 | 63 | 64 | verifySignature :: B.ByteString -> B.ByteString -> Request -> IO Bool 65 | verifySignature authtoken body r = 66 | case lookup "X-Twilio-Signature" $ requestHeaders r of 67 | Nothing -> return False -- If signature missing from request, must not be valid 68 | (Just givenSignature) -> return $ (givenSignature ==) $ calcSignature authtoken r $ body 69 | 70 | 71 | readRequestBodyAndPushback :: Request -> IO (B.ByteString, IO B.ByteString) 72 | readRequestBodyAndPushback req = do 73 | -- This loop body and then the ichunks rbody stuff comes from http://hackage.haskell.org/package/wai-extra-3.0.3.2/docs/src/Network-Wai-Middleware-RequestLogger.html 74 | -- ** BEGIN READ BODY 75 | let loop front = do 76 | bs <- requestBody req 77 | if BC.null bs 78 | then return $ front [] 79 | else loop $ front . (bs:) 80 | body <- loop id 81 | -- ** END READ BODY 82 | 83 | -- ** BEGIN BODY PUSHBACK 84 | ichunks <- newIORef body 85 | let rbody = atomicModifyIORef ichunks $ \chunks -> case chunks of 86 | [] -> ([], BC.empty) 87 | x:y -> (y, x) 88 | -- ** END BODY PUSHBACK 89 | 90 | return (B.concat body, rbody) 91 | 92 | 93 | 94 | -- | Middleware to validate Twilio request. Parameterized by API auth token. 95 | -- Returns 401 Unauthorized if the request does not contain a valid signature based on the given auth token. 96 | requestValidator :: 97 | B.ByteString -- ^ AuthToken from your Twilio page 98 | -> Middleware 99 | requestValidator authtoken app req respond = do 100 | -- strictRequestBody appears to work only once, so we re-insert result into request when validated. 101 | (body, rbody) <- readRequestBodyAndPushback req 102 | vs <- verifySignature authtoken body req 103 | case vs of 104 | False -> respond $ responseLBS unauthorized401 [] "Invalid X-Twilio-Signature" 105 | True -> app (req {requestBody = rbody}) respond 106 | 107 | 108 | -------------------------------------------------------------------------------- /src/Data/TransientStore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-| 3 | Module : Data.TransientStore 4 | Description : An IO-bound store of values, referenced by a serializable identifier, which expire automatically after a fixed time 5 | Copyright : (c) 2015 Steve Kollmansberger 6 | Maintainer : steve@kolls.net 7 | Stability : experimental 8 | 9 | Primarily to support web service sessions, where a requestor may abruptly stop requesting 10 | without indication that a session is complete, leading to a memory leak. 11 | 12 | Originally built to support web coroutines, where a coroutine (which cannot be serialized) 13 | must be stored while a serializable identifier is sent to the client, which may or may not use it 14 | later to continue the coroutine. Since some instances will not be resumed, a memory leak ensues 15 | unless old instances are cleared out, hence, the time limited factor. 16 | 17 | Instances are guaranteed not to be removed before the specified fixed time, but may linger for some 18 | time after, depending on implementation. 19 | -} 20 | module Data.TransientStore (TransientStore, create, peek, pop, insert, delete) where 21 | 22 | import Control.Applicative 23 | 24 | import qualified Data.HashMap.Strict as HM 25 | import Data.IORef 26 | import Data.Time.Clock 27 | import Data.UUID 28 | 29 | import System.Random 30 | 31 | 32 | 33 | data ITransientStore a = ITransientStore { 34 | ttl :: NominalDiffTime, -- ^ The minimum length of time a value is guaranteed to survive in the store after insertion 35 | lastCleanup :: UTCTime, -- ^ The last time a cleanup (search for and removal of old values) was run 36 | store :: !(HM.HashMap UUID (UTCTime, a)) -- ^ The actual store of key/value pairs, together with the time the value was inserted 37 | } 38 | 39 | type TransientStore a = IORef (ITransientStore a) 40 | 41 | -- | Create a new transient store and embed it in the IO monad. 42 | create :: NominalDiffTime -> -- ^ The "Time to Live", the minimum length of time a value is guaranteed to survive in the store after insertion 43 | IO (TransientStore a) 44 | create ttl = do 45 | now <- getCurrentTime 46 | newIORef $ ITransientStore ttl now HM.empty 47 | 48 | -- | Retrieve a value from the transient store without removing it. Instead, most users will call 'pop' to retrieve and remove in one operation. 49 | -- Peek'ing a value also renews its timestamp, keeping it alive. 50 | peek :: TransientStore a -- ^ The transient store to look in 51 | -> UUID -- ^ The key to look for (as returned by 'insert') 52 | -> IO (Maybe a) -- ^ The value, if it exists and is not expired, or Nothing otherwise 53 | peek tstore id = do 54 | -- Check if cleanup is needed, and retrieve value 55 | now <- getCurrentTime 56 | atomicModifyIORef' tstore (\istore -> let 57 | cleanedIStore = cleanIfNeeded now istore 58 | renewedIStore = cleanedIStore { store = HM.adjust (renew now) id (store cleanedIStore) } 59 | in 60 | (renewedIStore, snd <$> HM.lookup id (store cleanedIStore))) 61 | 62 | -- | Insert a new value into the store, returning a unique, serializable identifier 63 | insert :: TransientStore a -- ^ The transient store to insert into 64 | -> a -- ^ The value to insert 65 | -> IO UUID -- ^ A unique identifier representing the value 66 | insert tstore !value = do 67 | now <- getCurrentTime 68 | newid <- randomIO :: IO UUID 69 | atomicModifyIORef' tstore (\istore -> let cleanedIStore = cleanIfNeeded now istore in 70 | (cleanedIStore { store = HM.insert newid (now, value) (store cleanedIStore)}, ())) 71 | return newid 72 | 73 | -- | Delete a value from the store by key. If the key does not exist or has expired, the command is ignored. 74 | delete :: TransientStore a -- ^ The transient store to look in 75 | -> UUID -- ^ The key to look for (as returned by 'insert') 76 | -> IO () 77 | delete tstore id = do 78 | -- Check if cleanup is needed, and remove value 79 | now <- getCurrentTime 80 | atomicModifyIORef' tstore (\istore -> let cleanedIStore = cleanIfNeeded now istore in 81 | (cleanedIStore { store = HM.delete id (store cleanedIStore) }, ())) 82 | 83 | -- | Retrieve a value from the transient store and remove it. 84 | pop :: TransientStore a -- ^ The transient store to look in 85 | -> UUID -- ^ The key to look for (as returned by 'insert') 86 | -> IO (Maybe a) -- ^ The value, if it exists and is not expired, or Nothing otherwise 87 | pop tstore id = do 88 | mvalue <- peek tstore id 89 | delete tstore id 90 | return mvalue 91 | 92 | -- | Based on the ttl and last cleaned time, maybe clean the store, updating the last cleaned time if so 93 | cleanIfNeeded :: UTCTime -> ITransientStore a -> ITransientStore a 94 | -- we only want to filter if some time has elapsed, otherwise all the operations get really expensive ! 95 | -- we'll base it on ttl, so, in worst case, an element could live about 2x ttl 96 | cleanIfNeeded now istore | addUTCTime (ttl istore) (lastCleanup istore) < now = 97 | istore { 98 | lastCleanup = now, 99 | store = HM.filter (\(time, _) -> addUTCTime (ttl istore) time > now) (store istore) } 100 | | otherwise = istore 101 | 102 | renew :: UTCTime -> (UTCTime, a) -> (UTCTime, a) 103 | renew now (time, value) = (now, value) 104 | -------------------------------------------------------------------------------- /src/Twilio/IVR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, RecordWildCards #-} 2 | {-| 3 | Module : Twilio.IVR 4 | Description : A coroutine for interactive monadic Twilio IVR 5 | Copyright : (c) 2015 Steve Kollmansberger 6 | Maintainer : steve@kolls.net 7 | Stability : experimental 8 | 9 | IVR with Twilio can be very painful, since every interaction cycle requires a discrete 10 | request/response. This may be implemented using a separate web method for each possible 11 | stage in a conversation. Tracking state during a call is also problematic for the same reason. 12 | This module introduces a coroutine-based monad for Twilio IVR which makes extended 13 | interactions and state maintenance as seamless as console I/O. 14 | -} 15 | module Twilio.IVR (Response (..), IResponse, Geo(..), Call(..), TwilioIVRCoroutine, 16 | 17 | -- * Monadic functions used for controlling IVR 18 | say, gather, hangup, 19 | -- * Lens for gather 20 | message, timeout, finishOnKey, numDigits, action, 21 | -- * Lens for call 22 | callSid, accountSid, Twilio.IVR.from, 23 | 24 | -- * Support functions used to generate TwiML, not expected to be called by the user 25 | renderTwiML, makeRootTwiML) where 26 | 27 | import Control.Applicative 28 | 29 | import Control.Lens 30 | import Control.Lens.Setter 31 | import Control.Lens.TH 32 | 33 | import Control.Monad (void) 34 | 35 | import Control.Monad.Coroutine 36 | import qualified Control.Monad.Coroutine.SuspensionFunctors as SF 37 | import Control.Monad.Trans.Class 38 | 39 | import Text.XML.Light 40 | import Twilio.Key 41 | 42 | -- | A single interactive response entry, that expects the user the give input 43 | data IResponse = 44 | Gather { 45 | _message :: String, 46 | _timeout :: Int, -- ^ Timeout, in seconds, to wait between each digit 47 | _finishOnKey :: Maybe Key, -- ^ Optionally, the key to immediately terminate gathering 48 | _numDigits :: Int, -- ^ Maximum number of digits to gather 49 | _action :: String} 50 | deriving (Show, Eq) 51 | makeLenses ''IResponse 52 | 53 | defaultGather = Gather "" 5 (Just KPound) 50 "" 54 | 55 | -- | A single non-interactive response entry, that does not stop for user input 56 | data Response = 57 | Say { _sayMessage :: String } | 58 | Hangup 59 | deriving (Show, Eq) 60 | makeLenses ''Response 61 | 62 | -- | Information about location 63 | data Geo = 64 | Geo { 65 | _city :: String, 66 | _state :: String, 67 | _zip :: String, 68 | _country :: String 69 | } 70 | deriving (Show) 71 | 72 | -- | Information about the call 73 | data Call = 74 | Call { 75 | _callSid :: String, -- ^ The unique Twilio SID 76 | _accountSid :: String, -- ^ Your account SID 77 | _from :: String, -- ^ The phone number or identifier of the caller 78 | _to :: String, -- ^ The phone number of the called party 79 | _forwardedFrom :: String, -- ^ Optionally, information about a forwarded call 80 | _callerName :: String, -- ^ If requested, the looked up name of the caller 81 | _fromLoc :: Geo, -- ^ If available, the looked up origin of the call (from) 82 | _toLoc :: Geo } -- ^ If available, the looked up receipt location (to) 83 | deriving (Show) 84 | makeLenses ''Call 85 | 86 | -- | The main monadic type for IVR conversations 87 | type TwilioIVRCoroutine a = Coroutine (SF.Request (Either IResponse Response) [Key]) IO a 88 | 89 | -- | Speak a message to the user 90 | say :: String -> TwilioIVRCoroutine () 91 | say msg = 92 | void $ -- the "result" here is always the empty string, so discard it 93 | SF.request $ Right $ Say msg 94 | 95 | 96 | -- | Receive keypad entry from the user 97 | gather :: String -- ^ A message to 'say' inside the Gather command 98 | -> (IResponse -> IResponse) -- ^ A lens to change gather settings. 99 | -- Lens available are: 100 | -- 101 | -- [@timeout .~ (n :: Int)@] Sets the timeout, in seconds, to wait between each digit 102 | -- [@finishOnKey .~ (k :: Maybe Key)@] Optionally, sets the key to immediately terminate gathering 103 | -- [@numDigits .~ (n :: Int)@] Sets the maximum number of digits to listen for 104 | -> TwilioIVRCoroutine [Key] -- ^ Bind to the keys to receive the caller's keypad entry 105 | gather msg lens = SF.request <$> Left <$> lens $ (message .~ msg ) defaultGather 106 | 107 | -- | Terminate the call 108 | hangup :: TwilioIVRCoroutine () 109 | hangup = void $ SF.request $ Right Hangup 110 | 111 | 112 | 113 | 114 | string :: String -> Content 115 | string str = Text $ CData CDataText str Nothing 116 | 117 | 118 | renderTwiML :: Either IResponse Response -> Content 119 | renderTwiML (Left (Gather{..})) = Elem $ unode "Gather" (renderTwiML (Right $ Say _message)) & 120 | add_attrs [ 121 | Attr (unqual "timeout") (show _timeout), 122 | Attr (unqual "finishOnKey") (maybe "" show _finishOnKey), 123 | Attr (unqual "numDigits") (show _numDigits), 124 | Attr (unqual "method") "POST", 125 | Attr (unqual "action") _action ] 126 | renderTwiML (Right (Say msg)) = Elem $ unode "Say" (string msg) 127 | renderTwiML (Right Hangup) = Elem $ unode "Hangup" () 128 | 129 | makeRootTwiML :: [Content] -> Element 130 | makeRootTwiML = unode "Response" 131 | 132 | -------------------------------------------------------------------------------- /src/Network/Wai/Twilio/IVR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} 2 | {-| 3 | Module : Network.Wai.Twilio.IVR 4 | Description : A wai implementation for the Twilio IVR coroutines 5 | Copyright : (c) 2015 Steve Kollmansberger 6 | Maintainer : steve@kolls.net 7 | Stability : experimental 8 | 9 | Exposes coroutine-based Twilio IVR from 'Twilio.IVR' as a wai subroute 10 | for web hosting. 11 | -} 12 | module Network.Wai.Twilio.IVR (TIVRDB, TIVRSubRoute(..)) where 13 | 14 | import Control.Monad.IO.Class (liftIO) 15 | import Control.Monad.Coroutine 16 | import qualified Control.Monad.Coroutine.SuspensionFunctors as SF 17 | import Control.Lens.Setter 18 | 19 | import qualified Data.ByteString.Char8 as BSC 20 | import qualified Data.Text as TX 21 | import Data.TransientStore 22 | import Data.UUID 23 | 24 | import Network.HTTP.Types 25 | import Network.Wai 26 | import Network.Wai.Middleware.Approot 27 | import Network.Wai.Middleware.Routes 28 | 29 | import Text.XML.Light 30 | import Twilio.Key 31 | import Twilio.IVR 32 | 33 | import Web.PathPieces 34 | 35 | instance PathPiece UUID where 36 | fromPathPiece = fromString.TX.unpack 37 | toPathPiece = TX.pack.toString 38 | 39 | type TIVRDB = TransientStore ([Key] -> TwilioIVRCoroutine ()) 40 | 41 | -- | The wai subroute definition. Definer must provide a cross-request stateful 'TIVRDB' and the 'root' entry-point for incoming IVR calls. 42 | data TIVRSubRoute = TIVRSubRoute { 43 | db :: TIVRDB, -- ^ This data store must be persisted across requests to provide coroutine resume when Twilio responds 44 | root :: Call -> TwilioIVRCoroutine () -- ^ This function provides the entry point into the IVR when a call is received 45 | } 46 | 47 | 48 | 49 | mkRouteSub "TIVRSubRoute" "RenderRoute" [parseRoutes| 50 | /tivr New POST 51 | /tivr/#UUID Continue POST 52 | |] 53 | 54 | 55 | asXml :: Element -> HandlerM sub master () 56 | asXml e = asContent "text/xml" (TX.pack (showTopElement e)) 57 | 58 | queryLookup :: [(TX.Text, Maybe TX.Text)] -> TX.Text -> String 59 | queryLookup query key = case Prelude.lookup key query of 60 | (Just (Just val)) -> TX.unpack val 61 | _ -> "" 62 | 63 | executeTIVRStep :: RenderRoute master => TIVRDB -> TwilioIVRCoroutine () -> HandlerM TIVRSubRoute master [Content] 64 | executeTIVRStep db cont = do 65 | -- execute the coroutine, generating a result 66 | result <- liftIO $ resume cont 67 | -- every result is either a further coroutine (Left), or the final termination (right) 68 | case result of 69 | (Left (SF.Request eresp cont')) -> 70 | -- if the coroutine continues, it might be continuing with a non-interactive entry (like Say) 71 | -- we can just accumulate these, we don't need to send and redirect back for each one 72 | -- Or, it might be an interactive entry (like Gather) 73 | -- in which case, we have to go out for a response 74 | case eresp of 75 | 76 | (Left iresp) -> do -- interactive entry 77 | -- we're going to have to suspend while the request is handled by Twillio 78 | -- so place it into the transient store and send the ID for resuming 79 | newid <- liftIO $ insert db cont' 80 | -- build the URL for the action 81 | rootUrl <- getApprootMay <$> request 82 | routeUrl <- showRouteSub 83 | let url = TX.unpack $ routeUrl (Continue newid) 84 | let url' = case rootUrl of 85 | Nothing -> url 86 | (Just root) -> BSC.unpack root ++ url 87 | 88 | -- modify the interactive entry's action to point to the new url, and send 89 | return [renderTwiML $ Left ((action .~ url') iresp)] 90 | 91 | (Right resp) -> do -- Non-interactive entry 92 | -- recursively continue processing, acquiring further entries leading to either 93 | -- termination or another interactive entry 94 | reslt <- executeTIVRStep db 95 | (cont' undefined) -- Note: the continuation requires a parameter, but since it's non-interactive, we provide no digits. 96 | -- This will be forcably ignored anyways by the wrappers 97 | return $ renderTwiML eresp:reslt 98 | 99 | (Right final) -> return [renderTwiML $ Right Hangup] -- All processing done, make sure system hangs up 100 | 101 | 102 | 103 | queryGeo :: (TX.Text -> String) -> TX.Text -> Geo 104 | queryGeo query prefix = Geo (q "City") (q "State") (q "Zip") (q "Country") 105 | where q x = query (TX.append prefix x) 106 | 107 | postNew :: RenderRoute master => HandlerS TIVRSubRoute master 108 | postNew = runHandlerM $ do 109 | TIVRSubRoute db beginTCR <- sub 110 | -- for a new request, load the call params out of the body 111 | query <- queryLookup <$> parseQueryText <$> rawBody 112 | let qGeo = queryGeo query 113 | let call = Call (query "CallSid") (query "AccountSid") (query "From") (query "To") (query "ForwardedFrom") (query "CallerName") (qGeo "From") (qGeo "To") 114 | -- execute the first step using the specified entry point 115 | out <- executeTIVRStep db (beginTCR call) 116 | asXml $ makeRootTwiML out 117 | 118 | 119 | 120 | postContinue :: RenderRoute master => UUID -> HandlerS TIVRSubRoute master 121 | postContinue id = runHandlerM $ do 122 | TIVRSubRoute db _ <- sub 123 | -- we're not going to re-provide the call params (although they should all be there) 124 | -- instead, we're only going to go for the digits, which is what might have changed 125 | query <- queryLookup <$> parseQueryText <$> rawBody 126 | -- using the id given, extract the coroutine out of the transient store 127 | (Just cont) <- liftIO $ pop db id 128 | -- provide the digits and continue execution 129 | out <- executeTIVRStep db $ cont (read $ query "Digits") 130 | asXml $ makeRootTwiML out 131 | --------------------------------------------------------------------------------