module Network.AGI
( Digit(..)
, ppDigit
, ppEscapeDigits
, digitsToInteger
, AGI
, run
, fastAGI
, runInternal
, SoundType(..)
, sendRecv
, answer
, hangUp
, getData
, RecordResult(..)
, sayDigits
, sayNumber
, streamFile
, waitForDigit
, record
) where
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Error
import Data.Char
import Data.Generics
import Data.Maybe
import Data.Word
import Network
import Text.ParserCombinators.Parsec
import System.IO
import System.Posix.Signals
import System.Random
data AGIEnv = AGIEnv { agiVars :: [(String, String)]
, agiInH :: Handle
, agiOutH :: Handle
}
newtype AGI a = AGI { runAGI :: ReaderT AGIEnv IO a }
deriving (Monad, MonadIO, Functor, MonadError IOError, MonadReader AGIEnv)
data Digit
= Pound
| Star
| Zero
| One
| Two
| Three
| Four
| Five
| Six
| Seven
| Eight
| Nine
deriving (Eq, Ord, Read, Show, Enum, Data, Typeable)
ppDigit :: Digit -> Char
ppDigit Pound = '#'
ppDigit Star = '*'
ppDigit Zero = '0'
ppDigit One = '1'
ppDigit Two = '2'
ppDigit Three = '3'
ppDigit Four = '4'
ppDigit Five = '5'
ppDigit Six = '6'
ppDigit Seven = '7'
ppDigit Eight = '8'
ppDigit Nine = '9'
ppEscapeDigits :: [Digit] -> String
ppEscapeDigits digits = '"' : (map ppDigit digits ++ "\"")
digitsToInteger :: [Digit] -> Maybe Integer
digitsToInteger digits =
case reads (map ppDigit digits) of
[(i, [])] -> (Just i)
_ -> Nothing
type Command = String
data SoundType = WAV | GSM
deriving (Eq, Enum, Data, Typeable)
instance Show SoundType where
show WAV = "wav"
show GSM = "gsm"
run :: AGI a -> Handler -> IO a
run agi hupHandler =
do installHandler sigHUP hupHandler Nothing
runInternal agi stdin stdout
fastAGI :: Maybe PortID -> (HostName -> PortNumber -> AGI a) -> IO ()
fastAGI portId agi =
do installHandler sigPIPE Ignore Nothing
s <- listenOn $ fromMaybe (PortNumber 4573) portId
(forever $ (do (h, hostname, portNum) <- accept s
forkIO $ runInternal (agi hostname portNum) h h >> hClose h
)) `finally` (sClose s)
runInternal :: AGI a -> Handle -> Handle -> IO a
runInternal agi inh outh =
do vars <- readAgiVars inh
hSetBuffering inh LineBuffering
hSetBuffering outh LineBuffering
runReaderT (runAGI agi) (AGIEnv vars inh outh)
readAgiVars :: Handle -> IO [(String, String)]
readAgiVars inh =
do mAgiVar <- readAgiVar
case mAgiVar of
Nothing ->
return []
Just agiVar ->
do rest <- readAgiVars inh
return (agiVar:rest)
where readAgiVar :: IO (Maybe (String, String))
readAgiVar =
do l <- hGetLine inh
case l of
"" -> return Nothing
_ -> let (a,v) = break ((==) ':') l in
return (Just (a, dropWhile ((==) ' ') (tail v)))
sendRecv :: Command -> AGI String
sendRecv cmd =
do inh <- liftM agiInH $ ask
outh <- liftM agiOutH $ ask
liftIO $ do hPutStrLn inh cmd
hGetLine outh
answer :: AGI Bool
answer =
do res <- sendRecv "ANSWER"
parseResult (pResult >> pSuccessFailure) res
hangUp :: Maybe String
-> AGI Bool
hangUp mChannel =
do res <- sendRecv ("HANGUP" ++ (maybe "" (' ' :) mChannel))
parseResult (pResult >> ((char '1' >> return True) <|> (string "-1" >> return False))) res
getData :: FilePath
-> Maybe Integer
-> Maybe Integer
-> AGI (Maybe ([Digit], Bool))
getData fp mTimeout mMaxDigits =
let cmd =
"GET DATA " ++ fp ++
case (mTimeout, mMaxDigits) of
(Nothing, Nothing) -> ""
(Just timeout, Nothing) -> show timeout
(Nothing, Just maxDigits) -> "2000 " ++ show maxDigits
(Just timeout, Just maxDigits) -> show timeout ++" "++ show maxDigits
in
do res <- sendRecv cmd
parseResult p res
where
p = do pResult
(try pFail >> return Nothing) <|> (pDigitsWithTimeout >>= return . Just)
pFail = string "-1"
data RecordResult
= FailureToWrite
| FailureOnWaitFor
| HangUp
| Interrupted Digit
| Timeout
| RandomError String
deriving (Eq, Show, Data, Typeable)
record :: FilePath
-> SoundType
-> [Digit]
-> Maybe Integer
-> Maybe Integer
-> Bool
-> Maybe Integer
-> AGI (RecordResult, Integer)
record fp soundType escapeDigits length offset beep silence =
do res <- sendRecv $ ("RECORD FILE " ++ fp ++ " " ++ show soundType ++ " " ++
ppEscapeDigits escapeDigits ++ " " ++ (maybe "-1" show length) ++
(maybe "" (\o -> ' ': show o) offset) ++
(if beep then " beep" else "") ++
(maybe "" (\s -> " s=" ++ show s) silence))
parseResult p res
p = pResult >> (pFailureToWrite <|> pFailureOnWaitFor <|> pHangUp <|> pInterrupted <|> pTimeout <|> pRandomError)
where
pFailureToWrite =
do try (string "-1 (writefile)") >> return (FailureToWrite, 0)
pFailureOnWaitFor =
do try (string "-1 (waitfor)")
pSpace
ep <- pEndPos
return (FailureOnWaitFor, ep)
pHangUp =
do try (string "0 (hangup)")
pSpace
ep <- pEndPos
return (HangUp, ep)
pInterrupted = try $
do digit <- pAsciiDigit
pSpace
string "(dtmf)"
pSpace
ep <- pEndPos
return (Interrupted digit, ep)
pTimeout =
do try (string "0 (timeout)")
pSpace
ep <- pEndPos
return (Timeout, ep)
pRandomError = try $
do error <- manyTill anyChar (try (string " (randomerror)"))
pSpace
ep <- pEndPos
return (RandomError error, ep)
sayDigits :: [Digit]
-> [Digit]
-> AGI (Maybe (Maybe Digit))
sayDigits digits escapeDigits =
do res <- sendRecv $ "SAY DIGITS " ++ map ppDigit digits ++ " " ++ ppEscapeDigits escapeDigits
parseResult p res
where
p = do pResult
(string "-1" >> return Nothing) <|> (string "0" >> return (Just Nothing)) <|> (pAsciiDigit >>= return . Just . Just)
sayNumber :: Integer
-> [Digit]
-> AGI (Maybe (Maybe Digit))
sayNumber number escapeDigits =
do res <- sendRecv ("SAY NUMBER " ++ show number ++ " " ++ ppEscapeDigits escapeDigits)
parseResult p res
where
p = do pResult
(string "-1" >> return Nothing) <|> (string "0" >> return (Just Nothing)) <|> (pAsciiDigit >>= return . Just . Just)
streamFile :: FilePath
-> [Digit]
-> Maybe Integer
-> AGI (Either Integer (Maybe Digit, Integer))
streamFile filePath escapeDigits mSampleOffset =
do res <- sendRecv $ "STREAM FILE " ++ filePath ++ " " ++ ppEscapeDigits escapeDigits ++ (maybe "" (\so -> ' ' : show so) mSampleOffset)
parseResult p res
where
p =
do pResult
pFailure <|> pFailureOnOpen <|> pSuccess <|> pSuccessWithDigit
pFailure =
do string "-1"
pSpace
ep <- pEndPos
return (Left ep)
pFailureOnOpen = try $
do string "0 endpos=0"
return (Left 0)
pSuccess = try $
do string "0"
pSpace
ep <- pEndPos
return (Right (Nothing, ep))
pSuccessWithDigit = try $
do d <- pAsciiDigit
pSpace
ep <- pEndPos
return (Right ((Just d), ep))
waitForDigit :: Integer
-> AGI (Maybe (Maybe Digit))
waitForDigit timeout =
do res <- sendRecv $ "WAIT FOR DIGIT " ++ show timeout
parseResult p res
where
p = do pResult
(string "-1" >> return Nothing) <|> (string "0" >> return (Just Nothing)) <|> (pAsciiDigit >>= return . Just . Just)
parseResult p res =
case parse p res res of
(Left e) -> throwError (userError (show e))
(Right r) -> return $ r
pSuccessFailure :: CharParser () Bool
pSuccessFailure =
(char '0' >> return True) <|> (string "-1" >> return False)
pResult :: CharParser () String
pResult = string "200 result="
pSpace :: CharParser () String
pSpace = many (tab <|> char ' ')
pDigitsWithTimeout =
do digits <- many pDigit
pSpace
to <- (string "(timeout)" >> return True) <|> return False
return (digits, to)
pDigit :: CharParser () Digit
pDigit =
(char '#' >> return Pound) <|>
(char '*' >> return Star) <|>
(char '0' >> return Zero) <|>
(char '1' >> return One) <|>
(char '2' >> return Two) <|>
(char '3' >> return Three) <|>
(char '4' >> return Four) <|>
(char '5' >> return Five) <|>
(char '6' >> return Six) <|>
(char '7' >> return Seven) <|>
(char '8' >> return Eight) <|>
(char '9' >> return Nine)
pAsciiDigit :: CharParser () Digit
pAsciiDigit =
do ds <- many1 digit
case ds of
"35" -> return Pound
"42" -> return Star
"48" -> return Zero
"49" -> return One
"50" -> return Two
"51" -> return Three
"52" -> return Four
"53" -> return Five
"54" -> return Six
"55" -> return Seven
"56" -> return Eight
"57" -> return Nine
_ -> pzero <?> "The ascii character code " ++ ds ++ " (" ++ [chr (read ds)] ++ ") does not correspond to a digit on the keypad"
pEndPos :: CharParser () Integer
pEndPos =
do string "endpos="
ds <- many1 digit
return (read ds)