diff --git a/AGI.cabal b/AGI.cabal new file mode 100644 --- /dev/null +++ b/AGI.cabal @@ -0,0 +1,30 @@ +Name: AGI +Category: Network +Synopsis: A library for writing AGI scripts for Asterisk +Description: Asterisk is an open-source Voice over IP server + (VoIP). Asterisk provides a Asterisk Gateway Interface (AGI), which + can be used to write external programs that interact with + Asterisk. It is typically used for creating Interactive Voice + Response (IVR) systems. +Version: 1.0 +License: BSD3 +License-File: debian/copyright +Author: Jeremy Shaw +Maintainer: Jeremy Shaw +Homepage: http://www.n-heptane.com/nhlab/repos/haskell-agi +Build-Depends: base, parsec, mtl +Exposed-modules: + Network.AGI +Extra-Source-Files: + debian/changelog debian/compat debian/control debian/copyright + debian/haskell-agi-doc.docs debian/rules + examples/guessinggame/GuessingGame.hs + examples/guessinggame/sounds/guessing-game-correct.gsm + examples/guessinggame/sounds/guessing-game-intro.gsm + examples/guessinggame/sounds/guessing-game-yay.gsm + examples/guessinggame/sounds/guessing-game-higher.gsm + examples/guessinggame/sounds/guessing-game-lower.gsm + tests/Main.hs + +-- For more complex build options see: +-- http://www.haskell.org/ghc/docs/latest/html/Cabal/ diff --git a/Network/AGI.hs b/Network/AGI.hs new file mode 100644 --- /dev/null +++ b/Network/AGI.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module Network.AGI where + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader +import Data.Maybe +import Data.Word +import Text.ParserCombinators.Parsec +import System.IO +import System.Posix.Signals + +newtype AGI a = AGI { runAGI :: ReaderT [(String, String)] IO a } + deriving (Monad, MonadIO, Functor) + +type EscapeDigits = String +type Command = String +data Timeout = Timeout Word (Maybe Word) -- ^ timeout, max digits +type ReturnCode = Word + +data SoundType = Wav | GSM + +instance Show SoundType where + show Wav = "wav" + show GSM = "gsm" + +-- TODO: let user install a custom sipHUP handler (sigHUP is sent when the caller hangs ups) +run :: AGI a -> IO a +run agi = + do installHandler sigHUP Ignore Nothing + hSetBuffering stdin LineBuffering + hSetBuffering stdout LineBuffering + agiVars <- readAgiVars + runReaderT (runAGI agi) agiVars + +readAgiVars :: IO [(String, String)] +readAgiVars = + do mAgiVar <- readAgiVar + case mAgiVar of + Nothing -> + return [] + Just agiVar -> + do rest <- readAgiVars + return (agiVar:rest) + where readAgiVar :: IO (Maybe (String, String)) + readAgiVar = + do l <- getLine + case l of + "" -> return Nothing + _ -> let (a,v) = break ((==) ':') l in + return (Just (a, dropWhile ((==) ' ') (tail v))) + +sendRecv :: Command -> AGI (ReturnCode, String) +sendRecv cmd = + liftIO $ do putStrLn cmd + l <- getLine + let (c,r) = break ((==) ' ') l + return (read c, tail r) + +parseResult :: CharParser () (Int, Bool) +parseResult = + do string "result=" + digits <- many1 $ oneOf ('-':['0'..'9']) + skipMany (char ' ') + timeout <- parseTimeout + return (read digits, timeout) + +parseTimeout :: CharParser () Bool +parseTimeout = + do string "(timeout)" + return True + <|> + do return False + +answer :: AGI Bool +answer = + do (code, res) <- sendRecv "ANSWER" + case res of + "result=0" -> + return $ True + _ -> + return $ False + +hangUp :: Maybe String -> AGI (ReturnCode, String) +hangUp mChannel = + sendRecv ("HANGUP" ++ (fromMaybe "" mChannel)) + +-- TODO: does digit include # and * ? +getData :: FilePath -> Maybe Timeout -> AGI (ReturnCode, (Int, Bool)) +getData fp mTimeout = + let cmd = + "GET DATA " ++ fp ++ + case mTimeout of + Nothing -> "" + Just (Timeout timeout mMaxDigits) -> + " " ++ show timeout ++ + case mMaxDigits of + Nothing -> "" + Just maxDigits -> " " ++ show maxDigits + in + do (code, res) <- sendRecv cmd + case parse parseResult res res of + Left e -> + return $ (code, ((-1), False)) + Right (digits,timeout) -> + return $ (code, (digits, timeout)) + +record :: FilePath -> SoundType -> EscapeDigits -> Word -> Bool -> AGI (ReturnCode, String) +record fp st escapeDigits length beep = + sendRecv $ "RECORD FILE " ++ fp ++ " " ++ show st ++ " " ++ show escapeDigits ++ " " ++ show length ++ (if beep then " beep" else "") + +-- TODO: does digit include # and * ? +sayNumber :: Int -> EscapeDigits -> AGI (ReturnCode, String) +sayNumber num escapeDigits = + sendRecv $ "SAY NUMBER " ++ (show num) ++ " " ++ show escapeDigits + +-- TODO: what if the users enters DTMF +stream :: FilePath -> EscapeDigits -> AGI (ReturnCode, String) +stream fp ed = + sendRecv $ "STREAM FILE " ++ fp ++ " " ++ show ed + +-- TODO: does digit include # and * ? +-- TODO: positive timeouts only +waitForDigit :: Integer -> AGI (Maybe Int) +waitForDigit timeout = + do (code, res) <- sendRecv $ "WAIT FOR DIGIT " ++ show timeout + case parse parseResult res res of + Left e -> return Nothing -- error ? + Right (ascii, _) -> return (Just (ascii - 48)) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/debian/changelog b/debian/changelog new file mode 100644 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +haskell-agi (1.0) unstable; urgency=low + + * Initial Debian package. + + -- Jeremy Shaw Sat, 12 May 2007 19:54:42 -0700 + diff --git a/debian/compat b/debian/compat new file mode 100644 --- /dev/null +++ b/debian/compat @@ -0,0 +1,1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 --- /dev/null +++ b/debian/control @@ -0,0 +1,45 @@ +Source: haskell-agi +Priority: optional +Section: devel +Maintainer: Jeremy Shaw +Build-Depends: debhelper (>= 4.0.0), haskell-devscripts (>=0.5.12), ghc6 (>=6.4), ghc6-prof +Build-Depends-Indep: haddock, hugs (>= 98.200503.08) +Standards-Version: 3.7.2.0 + +Package: libghc6-agi-dev +Section: libdevel +Architecture: any +Depends: ${haskell:Depends} +Description: A Haskell AGI library + A library for creating applications that can be called from Asterisk + using the Asterisk Gateway Interface (AGI). + . + This package contains the libraries compiled for GHC 6. + +Package: libghc6-agi-prof +Section: libdevel +Architecture: any +Depends: ${haskell:Depends} +Description: A Haskell AGI library + A library for creating applications that can be called from Asterisk + using the Asterisk Gateway Interface (AGI). + . + This package contains the libraries compiled for GHC 6 with profiling + enabled. + +Package: libhugs-agi +Section: libdevel +Architecture: all +Depends: ${haskell:Depends} +Description: A Haskell AGI library + A library for creating applications that can be called from Asterisk + using the Asterisk Gateway Interface (AGI). + . + This package contains the libraries compiled for Hugs. + +Package: haskell-agi-doc +Section: doc +Architecture: all +Description: Documentation for a Haskell AGI library + A library for creating applications that can be called from Asterisk + using the Asterisk Gateway Interface (AGI). diff --git a/debian/copyright b/debian/copyright new file mode 100644 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,31 @@ +Copyright (c) 2007, Jeremy Shaw + +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. + + * The names of contributors may not 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/debian/haskell-agi-doc.docs b/debian/haskell-agi-doc.docs new file mode 100644 --- /dev/null +++ b/debian/haskell-agi-doc.docs @@ -0,0 +1,1 @@ +dist/doc/html diff --git a/debian/rules b/debian/rules new file mode 100644 --- /dev/null +++ b/debian/rules @@ -0,0 +1,86 @@ +#!/usr/bin/make -f + +# Uncomment this to turn on verbose mode. +#export DH_VERBOSE=1 + +build: build-stamp +build-stamp: + dh_testdir + + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp + + # Add here commands to clean up after the build process. + if [ -x setup ] && [ -e .setup-config ] ; then ./setup clean ; fi + rm -rf setup Setup.hi Setup.ho Setup.o .*config* dist html + #make clean + + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs -a + + # Add here commands to install the package into debian/tmp + dh_haskell -a + +build-indep: build-indep-stamp +build-indep-stamp: + dh_testdir + +install-indep: build-indep + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs -i + + # Add here commands to install the package into debian/tmp + dh_haskell -i + ./Setup.hs haddock + #make doc + +# Build architecture-independent files here. +binary-indep: build-indep install-indep + dh_testdir + dh_testroot + dh_installchangelogs -i + dh_installdocs -i + dh_installexamples -i + dh_installman -i + dh_link -i + dh_strip -i + dh_compress -i + dh_fixperms -i + dh_installdeb -i + dh_shlibdeps -i + dh_gencontrol -i + dh_md5sums -i + dh_builddeb -i + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot + dh_installchangelogs -a + dh_installdocs -a + dh_installexamples -a + dh_installman -a + dh_link -a + dh_strip -a + dh_compress -a + dh_fixperms -a + dh_installdeb -a + dh_shlibdeps -a + dh_gencontrol -a + dh_md5sums -a + dh_builddeb -a + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install build-indep install-indep diff --git a/examples/guessinggame/GuessingGame.hs b/examples/guessinggame/GuessingGame.hs new file mode 100644 --- /dev/null +++ b/examples/guessinggame/GuessingGame.hs @@ -0,0 +1,69 @@ +module Main where + +-- Standard Haskell Modules + +import Control.Monad.Trans +import Data.Maybe +import Data.Word +import System.IO +import System.Random +import System.Posix.Unistd + +-- 3rd Party Modules + +import Network.AGI + +main :: IO () +main = + run mainAGI + +mainAGI :: AGI () +mainAGI = + do answer + liftIO $ sleep 1 + playGame + hangUp Nothing + return () + +playGame :: AGI () +playGame = + do secretDigit <- liftIO $ randomRIO (0, 9) + stream "guessing-game-intro" [] + guess <- waitForDigit (-1) + play (compare secretDigit) (fromMaybe 0 guess) + return () + +play oracle guess = + loop guess + where + loop guess = + case oracle guess of + LT -> + do stream "guessing-game-lower" [] + sayNumber guess [] + nextGuess <- waitForDigit (-1) + loop (fromMaybe guess nextGuess) + GT -> + do stream "guessing-game-higher" [] + sayNumber guess [] + nextGuess <- waitForDigit (-1) + loop (fromMaybe guess nextGuess) + EQ -> + do stream "guessing-game-yay" [] + sayNumber guess [] + stream "guessing-game-correct" [] + +{- + +Let's play a game! I am think of a number between 0 and 9. Can you +guess what it is? Enter your guess using the number pad on your phone. + +Sorry, the number I am thinking of is higher than + +Sorry, the number I am thinking of is less than + +Yay! + +is the number I was thinking of! How did you know? + +-} diff --git a/examples/guessinggame/sounds/guessing-game-correct.gsm b/examples/guessinggame/sounds/guessing-game-correct.gsm new file mode 100644 Binary files /dev/null and b/examples/guessinggame/sounds/guessing-game-correct.gsm differ diff --git a/examples/guessinggame/sounds/guessing-game-higher.gsm b/examples/guessinggame/sounds/guessing-game-higher.gsm new file mode 100644 Binary files /dev/null and b/examples/guessinggame/sounds/guessing-game-higher.gsm differ diff --git a/examples/guessinggame/sounds/guessing-game-intro.gsm b/examples/guessinggame/sounds/guessing-game-intro.gsm new file mode 100644 Binary files /dev/null and b/examples/guessinggame/sounds/guessing-game-intro.gsm differ diff --git a/examples/guessinggame/sounds/guessing-game-lower.gsm b/examples/guessinggame/sounds/guessing-game-lower.gsm new file mode 100644 Binary files /dev/null and b/examples/guessinggame/sounds/guessing-game-lower.gsm differ diff --git a/examples/guessinggame/sounds/guessing-game-yay.gsm b/examples/guessinggame/sounds/guessing-game-yay.gsm new file mode 100644 --- /dev/null +++ b/examples/guessinggame/sounds/guessing-game-yay.gsm @@ -0,0 +1,4 @@ +֞“aÑPA´½:”\%6o6õ–¡øì’9$^ »Ñ²cÛk–ڀé3æ(ï!¶œ®ºƒZu¥…Âc„ÂI2W{Ò[ü²Éb ¿øŠjá«$͢ﭫk*jŸWg$ ñhÛÔÄþM…‰ìžHƒ}Hû ™š}(—+3ÔãyÈÆW•8â֑{ÿSµª¾âQ#ò±Šór+ðÜs‹&_)¸Üq sÎ“×T?d¥ŽÙæH¥i2täm̜›°8—M«kÑs8ݸ8ÝיCÿœ^ïڔÖâ¹ +ÖiŽáYtÇ\NJàP¹²OOٞK+\STµͧ'{ÕÄÓéÆæQ…#¸ºŸŸÖ»©Ô¸Ø còZÕJVq¹h6¯M)雵¥I©du²qjy,Ž×!”vJuÔ£Öáu­t#XªÁSY›:ÁÄÁ•B¥v!ÕÖâ•fç³´:µŠîsl"—›SŒt°Å/笴55×¥$Á²×\űhuRÔ.: S›rÁku9ÌéT3ku9ÒÖÞ¥Yäëò>¤-Êåw‘‰\’·QÑê̊J-Qò)†nÇZÖa”©cy­OMiáMQQ­h‰ùE£±ôªSR+8uKÁÕ£µ*R¥2×g&I9}ƒdé¯U2¦äéµ'©1E½š\Õbµ²S«®šêQó„×1wSVä˜ÙíÅ!YŽ×…. 8IYu֝úˇqÈßM¦·[Š–ö›]0íCRç‹Q[œ ɓÖ†7é0%nÈB¶_Ï Ð‘>taÏ·ôr“óñ0ԝî†ÓÖ_v6ÛepÂVgKÉ17y‰(çg’ô܍֥io[SN9?ÕÝ~»ŸˆÝŽ:¤mqËDÍ8Ýó#vQTr®<ïP; ÔÞ§z#éQaÎ%4ë0%/ØÓ{PÖüiÇ}-wÃy—4Óß·yÚ/¦ãvQ+ðÐ'Lêțƒj™Æ.bbÅPU‘¦çӟ¯²‡,UK³“Í+H”–Ñ%H…Úø{m6ä°ÉÔ\—rbÕ +æ§I¼†Î)áu“a‘.N”©TÝÛm)"tÉ/ÕÛOv›•êA{©ýáKøUFëf™Jt6Ù0å p7kÀ՛Vºb›-2ìOJ4é'aVÊ&íJéŽó ì¢ìNø…Ôœv¹âðËPm/ñ#¡)¹ +ÕLÆ¢«`%n_ ­)Ô$wÌÕ[nµZ§ ˜v+ÂRëÄ£mßa[jä¬jí‚Té'lͰ՚^ùá[Ç7¡ÊN¦Q%²° ̪ÉXãiж¬æ^ÃÄ¥7ÕZf}Z\ÆnZNqXÇï­' ¦¨y[¶”¨†ûcŒ&œÖM½È—G¿œ6·¤†?[.6혥¹á‰+#܅O\q3؝Dz®¥ÊÌÄG©$¬.­%[°ÅØÝp$ëê¦Ù,eFÅÙ`îXÃó§ 4Ó¢ÄK´o £î¤¸ïvH#¬å¹-jIØál–&à㊴ک˜Á•TÝ^´Ÿ“'j ƒ™k:(Öœt¦Ý؂ºº¸­®Â×%9ôèÃHÛñϒb¼­mëÝÖ_sê#žÂ;¦}Úuèè¾…øü¢¢¢[­É–Â' MRB diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.HUnit + +test1 = TestCase (assertEqual "1==1" True (1==1)) + +tests = TestList [test1] + +main = runTestTT tests