module Network.EventSocket
(
EventSocketMessage(..)
,EventSocketState
,EventType(..)
,EventSocketError(..)
,EventSocketCommand(..)
,SessionState(sessUUID,sessVariables)
,EvtKVMap
,ESUUID
,EventSocketT
,EventSocketIO(..)
,startEventSocket
,connectInbound
,runEventSocketT
,modifySyncMode
,modifyDebugLevel
,registerEventHandler
,unregisterEventHandler
,EventId
,EventHandlerResult(..)
,EventHandlerFunc(..)
,syncPoint
,esRun
,esRunActions
,getSession
,apiAndReply
,commandAndReply
,withUUID
,getUUID
,sendAPI
,sendCommand
,waitForEvent
,eventSocketReadEventsUntil
,newEventSocketState
) where
import IO (Handle, hClose, hFlush, bracket, hPutStrLn, stderr, hReady)
import Data.Maybe (fromMaybe, fromJust, isJust)
import Data.Char (toLower, isSpace, ord, chr)
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as B
import qualified Control.Exception as Exc (try, finally)
import Control.Arrow ((***))
import Control.Monad.State.Strict (get, gets, put, modify, StateT, MonadState, runStateT)
import Control.Monad.Error (throwError, ErrorT, MonadError, liftM, ap, Error(noMsg), runErrorT)
import Control.Concurrent (forkIO)
import Control.Monad.Trans (MonadIO)
import Control.Applicative (Applicative, pure, (<*>))
import Control.Monad (when, forever, Monad)
import Control.Monad.Trans (lift, liftIO, MonadTrans)
import Network (accept)
import Network.Socket (HostName, PortNumber, Socket, SockAddr(..), SocketOption(..), Family(..), SocketType(..), listen, sClose, inet_addr, setSocketOption, bindSocket, defaultProtocol, socket)
newtype (Monad m, EventSocketIO h) => EventSocketT h m a =
EventSocketT { unEventSocketT :: ErrorT EventSocketError (StateT (EventSocketState h m) m) a }
deriving (Monad, MonadIO, MonadState (EventSocketState h m), MonadError EventSocketError)
instance (Monad m, EventSocketIO h) => Functor (EventSocketT h m) where
fmap = Control.Monad.Error.liftM
instance (Monad m, EventSocketIO h) => Applicative (EventSocketT h m) where
pure = return
(<*>) = Control.Monad.Error.ap
instance EventSocketIO h => MonadTrans (EventSocketT h) where
lift = EventSocketT . lift . lift
instance Show (h -> IO B.ByteString) where
show _ = "((h -> IO ByteString))"
instance Show (h -> Int -> IO B.ByteString) where
show _ = "((h -> Int -> IO ByteString))"
instance Show (h -> B.ByteString -> IO ()) where
show _ = "((h -> ByteString -> IO ()))"
data EventType
= E_Start
| E_End
| E_Other B.ByteString
| E_APIResponse
| E_CommandReply
| E_CHANNEL_CREATE
| E_CHANNEL_DESTROY
| E_CHANNEL_STATE
| E_CHANNEL_ANSWER
| E_CHANNEL_HANGUP
| E_CHANNEL_HANGUP_COMPLETE
| E_CHANNEL_EXECUTE
| E_CHANNEL_EXECUTE_COMPLETE
| E_CHANNEL_BRIDGE
| E_CHANNEL_UNBRIDGE
| E_CHANNEL_PROGRESS
| E_CHANNEL_PROGRESS_MEDIA
| E_CHANNEL_OUTGOING
| E_CHANNEL_PARK
| E_CHANNEL_UNPARK
| E_CHANNEL_APPLICATION
| E_CHANNEL_ORIGINATE
| E_CHANNEL_UUID
| E_SHUTDOWN
| E_MODULE_LOAD
| E_MODULE_UNLOAD
| E_RELOADXML
| E_NOTIFY
| E_SEND_MESSAGE
| E_RECV_MESSAGE
| E_REQUEST_PARMS
| E_CHANNEL_DATA
| E_GENERAL
| E_COMMAND
| E_SESSION_HEARTBEAT
| E_CLIENT_DISCONNECTED
| E_SERVER_DISCONNECTED
| E_SEND_INFO
| E_RECV_INFO
| E_CALL_SECURE
| E_NAT
| E_RECORD_START
| E_RECORD_STOP
| E_CALL_UPDATE
| E_API
| E_BACKGROUND_JOB
| E_CUSTOM
| E_RE_SCHEDULE
| E_HEARTBEAT
| E_DETECTED_TONE
| E_ALL
| E_LOG
| E_INBOUND_CHAN
| E_OUTBOUND_CHAN
| E_STARTUP
| E_PUBLISH
| E_UNPUBLISH
| E_TALK
| E_NOTALK
| E_SESSION_CRASH
| E_DTMF
| E_MESSAGE
| E_PRESENCE_IN
| E_PRESENCE_OUT
| E_PRESENCE_PROBE
| E_MESSAGE_WAITING
| E_MESSAGE_QUERY
| E_ROSTER
| E_CODEC
| E_DETECTED_SPEECH
| E_PRIVATE_COMMAND
| E_TRAP
| E_ADD_SCHEDULE
| E_DEL_SCHEDULE
| E_EXE_SCHEDULE
deriving (Show,Eq,Ord,Read)
data EventSocketCommand
= CmdEvents { format :: B.ByteString
, events :: [B.ByteString]
}
| CmdFilter { isDelete :: Bool
, eventHeader :: B.ByteString
, eventValue :: B.ByteString
}
| CmdLinger
| CmdSet { key :: B.ByteString
, val :: B.ByteString
}
| CmdHangup {
reason :: B.ByteString
}
| CmdSleep {
duration :: Int
}
| CmdAnswer
| CmdPlayGather {
minDigits :: Int,
maxDigits :: Int,
tries :: Int,
timeout :: Int,
terminators :: B.ByteString,
file :: B.ByteString,
invalidFile :: B.ByteString,
varName :: B.ByteString,
regexp :: B.ByteString
}
| CmdBridge { destinations :: [B.ByteString] }
| CmdSay { text :: B.ByteString }
| CmdSpeak { text :: B.ByteString }
| CmdPlay { filename :: B.ByteString }
| CmdRecord { filename :: B.ByteString, maxLength :: Int }
| CmdMetaApp { listenKey, listenTo, respondOn :: Char, appString :: B.ByteString }
| CmdSync
deriving Show
data EventSocketIO h => EventSocketState h m
= EventSocketState {
esRunning :: Bool
, esHandle :: h
, esHostName :: HostName
, esPortNumber :: PortNumber
, esEvents :: [EventSocketMessage]
, esSyncMode :: Bool
, esHandleEvents :: Bool
, esUUID :: B.ByteString
, esSeq :: Int
, esSessions :: M.Map B.ByteString (SessionState h m)
, esGlobalSession :: SessionState h m
, esDepth :: Int
, esDebugLevel :: Int
} deriving Show
data EventSocketIO h => SessionState h m
= SessionState {
sessUUID :: B.ByteString
, sessVariables :: EvtKVMap
, sessEvents :: M.Map EventType (S.Set (EventHandler h m))
} deriving Show
data EventHandlerResult = EHStopEvents
| EHContinue
| EHStopReading
deriving (Show,Eq)
type EventId = (Int,B.ByteString,EventType)
data EventSocketIO h => EventHandlerFunc h m = EventHandlerFunc (EventSocketMessage -> EventSocketT h m (Maybe (EventHandlerFunc h m),EventHandlerResult))
unEFunc (EventHandlerFunc f) = f
instance Show (EventHandlerFunc h m) where
show _ = "((EventSocketCallback))"
instance EventSocketIO h => Ord (EventHandler h m) where
compare EventHandler { ehPriority = i1 } EventHandler { ehPriority = i2 } = compare i1 i2
instance EventSocketIO h => Eq (EventHandler h m) where
i1 == i2 = ehID i1 == ehID i2
data EventSocketIO h => EventHandler h m =
EventHandler { ehID :: EventId
, ehPriority :: Int
, ehHandler :: EventHandlerFunc h m
} deriving (Show)
data EventSocketError
= UnknownError
| NetworkError String
| ParseError String
| ProtocolError String
| GeneralError String
deriving Show
data EventSocketMessage
= EventSocketMessage {
esmType :: EventType,
esmHeaders :: EvtKVMap,
esmSuccess :: Bool,
esmData :: Either B.ByteString EvtKVMap
}
deriving (Show,Eq,Ord)
instance Error EventSocketError where
noMsg = UnknownError
type ESUUID = B.ByteString
type EvtKVMap = M.Map B.ByteString B.ByteString
class EventSocketIO h where
esioBReadLine :: h -> IO B.ByteString
esioBRead :: h -> Int -> IO B.ByteString
esioBWrite :: h -> B.ByteString -> IO ()
esioFlush :: h -> IO ()
esioReady :: h -> IO Bool
instance EventSocketIO Handle where
esioBReadLine = B.hGetLine
esioBRead = B.hGet
esioBWrite = B.hPutStr
esioFlush = hFlush
esioReady = hReady
runEventSocketT :: (MonadIO m, EventSocketIO h)
=> EventSocketT h m a
-> EventSocketState h m
-> m (Either EventSocketError a, (EventSocketState h m))
runEventSocketT (EventSocketT ma) = runStateT (runErrorT ma)
makeListenSocket :: HostName -> PortNumber -> IO Socket
makeListenSocket host port = do
sock <- socket AF_INET Stream defaultProtocol
ia <- inet_addr host
setSocketOption sock ReuseAddr 1
bindSocket sock (SockAddrInet port ia)
listen sock 128
return sock
acceptLoop :: Socket
-> (Handle -> HostName -> PortNumber -> IO ())
-> IO ()
acceptLoop sock f = forever $ do
mc <- Exc.try $ accept sock
case mc of
Left (e :: IOError) -> hPutStrLn stderr $ "[EVENTSOCKET] Error accepting connection: " ++ show e
Right (handle, host, port) ->
do forkIO $ (f handle host port >> B.hPutStr handle (B.pack "exit\r\n\r\n") >> hClose handle) `Exc.finally` hClose handle
return ()
startEventSocket :: HostName
-> PortNumber
-> (EventSocketState Handle m -> IO ())
-> IO ()
startEventSocket host portid eh = bracket (makeListenSocket host portid) (sClose) (flip acceptLoop f)
where f handle connhost connport = let st = newEventSocketState handle connhost connport
in eh st
newEventSocketState :: EventSocketIO h
=> h
-> HostName
-> PortNumber
-> EventSocketState h m
newEventSocketState handle connhost connport =
EventSocketState { esRunning = True
, esSeq = 0
, esHandle = handle
, esHostName = connhost
, esPortNumber = connport
, esEvents = []
, esSyncMode = True
, esHandleEvents = False
, esUUID = B.empty
, esSessions = M.empty
, esDepth = 0
, esGlobalSession = SessionState { sessUUID = B.empty
, sessEvents = M.empty
, sessVariables = M.empty
}
, esDebugLevel = 0
}
modifySyncMode :: (Monad m, EventSocketIO h) => (Bool -> Bool) -> EventSocketT h m Bool
modifySyncMode f = modify (\est -> est { esSyncMode = f $ esSyncMode est }) >> get >>= return . esSyncMode
modifyDebugLevel :: (Monad m, EventSocketIO h) => (Int -> Int) -> EventSocketT h m Int
modifyDebugLevel f = modify (\est -> est { esDebugLevel = f $ esDebugLevel est }) >> get >>= return . esDebugLevel
unregisterEventHandler :: (Monad m, EventSocketIO h) => EventId
-> EventSocketT h m ()
unregisterEventHandler eid@(_,uuid,et) = do
let isglobal = B.null uuid
deletefromsession sess = sess { sessEvents = M.update delf et $ sessEvents sess }
delf i = let nset = S.filter ((eid /=) . ehID) i
in if S.null nset then Nothing else Just nset
if isglobal
then modify $ \est -> est { esGlobalSession = deletefromsession $ esGlobalSession est }
else modify $ \est -> est { esSessions = M.update (Just . deletefromsession) uuid $ esSessions est }
registerEventHandler :: (MonadIO m, EventSocketIO h) => B.ByteString
-> EventType
-> Int
-> EventHandlerFunc h m
-> EventSocketT h m EventId
registerEventHandler uuid et prio f = do
st <- get
let est = st
putinsess sess eh = sess { sessEvents = M.insertWith insertfunc et (S.singleton eh) $ sessEvents sess }
insertfunc nv ov = S.insert (head $ S.toList nv) ov
nid = (esSeq est,uuid,et)
nh = EventHandler { ehHandler = f
, ehID = nid
, ehPriority = prio
}
isglobal = B.null uuid
if isglobal
then
let gsess = esGlobalSession est
in put est { esGlobalSession = putinsess gsess nh, esSeq = esSeq est + 1 }
else
let sess = fromMaybe newsess $ M.lookup uuid $ esSessions est
newsess = SessionState { sessUUID = uuid, sessVariables = M.empty, sessEvents = M.empty }
in put est { esSessions = M.insert uuid (putinsess sess nh) $ esSessions est, esSeq = esSeq est + 1 }
return nid
withUUID :: (Monad m, EventSocketIO h) => B.ByteString
-> (EventSocketT h m a)
-> EventSocketT h m a
withUUID uuid f = do
st <- get
let olduuid = esUUID st
retval <- f
nst <- get
let newuuid = esUUID nst
when (newuuid == uuid) $
put $ nst { esUUID = olduuid }
return retval
waitForEvent :: (MonadIO m, EventSocketIO h) => EventType
-> EventSocketT h m [EventSocketMessage]
waitForEvent evt = do
dbug 4 $ "[ Reading events until " ++ show evt
result <- fmap snd $ eventSocketReadEventsUntil $ maybe (return True) (return . (==evt) . esmType)
dbug 4 $ "] Got events: " ++ show result
return result
commandAndReply :: (MonadIO m, EventSocketIO h) => B.ByteString
-> B.ByteString
-> EventSocketT h m [EventSocketMessage]
commandAndReply cmd args = do
sendCommand cmd args
(ok, events) <- eventSocketReadEventsUntil $
\arg -> case arg of
Nothing -> return True
Just msg -> return $ esmType msg == E_CommandReply
when (not ok) $
throwError . GeneralError $ "Failed to get command reply."
return events
sendCommand :: (MonadIO m, EventSocketIO h) => B.ByteString
-> B.ByteString
-> EventSocketT h m ()
sendCommand cmd args =
let header uuid = B.concat [B.pack "sendmsg", if B.null uuid then B.empty else B.append (B.singleton ' ') uuid,
B.pack "\r\ncall-command: execute\nexecute-app-name: "]
argstr = B.pack "\nexecute-app-arg: "
footer = B.pack "\nevent-lock: true\n\n"
cmdstr locked uuid = B.concat [header uuid, cmd,
if not (B.null args) then B.append argstr args else B.empty,
if locked then footer else B.pack "\r\n\r\n"]
in do st <- get
eWrite $ cmdstr (esSyncMode st) (esUUID st)
apiAndReply :: (MonadIO m, EventSocketIO h) => B.ByteString
-> B.ByteString
-> EventSocketT h m [EventSocketMessage]
apiAndReply cmd args = do
sendAPI cmd args
(ok, events) <- eventSocketReadEventsUntil $
\arg -> case arg of
Nothing -> return True
Just msg -> return $ esmType msg == E_APIResponse
when (not ok) $ throwError . GeneralError $ "Failed to get API response."
return events
sendAPI :: (MonadIO m, EventSocketIO h) => B.ByteString
-> B.ByteString
-> EventSocketT h m ()
sendAPI cmd args =
let cmdstr = B.append (B.intercalate (B.singleton ' ') [cmd,args]) $ B.pack "\r\n\r\n"
in eWrite cmdstr
connectInbound :: (MonadIO m, EventSocketIO h) => EventSocketT h m EventSocketMessage
connectInbound = do
st <- get
eWrite $ B.pack "connect\r\n\r\n"
msg <- readEvtKVMap False
case M.lookup (B.pack "unique-id") msg of
Nothing -> throwError . ProtocolError $ "Could not find Unique-Id in initial response."
Just u ->
let gsess = (esGlobalSession st)
{ sessUUID = u
, sessVariables = msg
}
in modify $ \est -> est { esUUID = u
, esGlobalSession = gsess
, esSessions = M.insertWith' (\_ oi -> oi { sessVariables = msg }) u gsess $ esSessions est
}
return EventSocketMessage { esmType = E_Start
, esmHeaders = msg
, esmSuccess = True
, esmData = Left B.empty
}
syncPoint :: (MonadIO m, EventSocketIO h)
=> EventSocketT h m [EventSocketMessage]
syncPoint = do
modify $ \st -> st { esSeq = esSeq st + 1 }
st <- get
let arg = B.append (B.pack "tone_stream://%(0,0,") (B.pack $ show (esSeq st + 1234567) ++ ")")
sendCommand (B.pack "playback") arg
(ok,ms) <- eventSocketReadEventsUntil (f arg)
when (not ok) $ throwError $ GeneralError $ "eventSocketReadEventsUntil returned failure."
return ms
where
f arg Nothing = return True
f arg (Just m) | esmType m /= E_CHANNEL_EXECUTE_COMPLETE = return False
| otherwise = let keepreading = isJust $ do
let Right hdrs = esmData m
application <- M.lookup (B.pack "application") hdrs
applicationdata <- M.lookup (B.pack "application-data") hdrs
applicationresponse <- M.lookup (B.pack "application-response") hdrs
if B.pack "playback" == application &&
arg == applicationdata &&
B.pack "FILE PLAYED" == applicationresponse
then Just True
else Nothing
in return keepreading
eventSocketReadEventsUntil :: (MonadIO m, EventSocketIO h)
=> (Maybe EventSocketMessage -> EventSocketT h m Bool)
-> EventSocketT h m (Bool, [EventSocketMessage])
eventSocketReadEventsUntil f = do
st <- get
when (esDepth st > 1) $ throwError $ GeneralError $ "Not allowed to recurse into EventSocket from event handler."
ready <- f Nothing
if ready
then do
msg <- readRawMessage >>= buildMessage
when (esmType msg == E_CHANNEL_DATA) $
updateSession msg
evtresult <- runEvents msg
done <- f $ Just msg
if done || evtresult == EHStopReading
then ret True
else eventSocketReadEventsUntil f
else ret False
where
ret success = do
rawstate <- get
put $ rawstate { esEvents = [] }
return (success, esEvents rawstate)
updateSession :: (MonadIO m, EventSocketIO h) => EventSocketMessage -> EventSocketT h m ()
updateSession msg = do
do edata <- case esmData msg of
Left _ -> throwError . ProtocolError $ "CHANNEL_DATA event without key/value data."
Right d -> return d
euuid <- case M.lookup (B.pack "unique-id") edata of
Nothing -> throwError . ProtocolError $ "CHANNEL_DATA event without Unique-Id field in data."
Just u -> return u
dbug 5 $ "> Updating session " ++ show euuid ++ ": " ++ show edata
est <- get
let sess = (fromMaybe newsess $ M.lookup euuid $ esSessions est) { sessVariables = edata }
newsess = SessionState { sessUUID = euuid
, sessEvents = M.empty
, sessVariables = M.empty }
modify $ \est -> est { esSessions = M.insert euuid sess $ esSessions est
, esGlobalSession = if euuid == esUUID est
then (esGlobalSession est) { sessVariables = edata }
else esGlobalSession est }
getSession :: (MonadIO m, EventSocketIO h)
=> ESUUID
-> EventSocketT h m (Maybe (SessionState h m))
getSession uuid = do
est <- get
let euuid = if B.null uuid then esUUID est else uuid
return $ M.lookup euuid $ esSessions est
getUUID :: (MonadIO m, EventSocketIO h) => EventSocketT h m ESUUID
getUUID = esUUID `fmap` get
runEvents :: (MonadIO m, EventSocketIO h) => EventSocketMessage -> EventSocketT h m EventHandlerResult
runEvents msg = do
est <- get
let globalevents = fromMaybe S.empty $ M.lookup (esmType msg) (sessEvents $ esGlobalSession est)
sessevents = fromMaybe S.empty $ do
evtdata <- either (const Nothing) Just $ esmData msg
uuid <- M.lookup (B.pack "unique-id") evtdata
sess <- M.lookup uuid $ esSessions est
M.lookup (esmType msg) $ sessEvents sess
dbug 4 $ "| session events (" ++ show (esmType msg) ++ ") = " ++ show sessevents
dbug 4 $ "| global events (" ++ show (esmType msg) ++ ") = " ++ show globalevents
runEvents' $ S.toAscList globalevents ++ S.toAscList sessevents
where
runEvents' [] = return EHContinue
runEvents' (e:es) =
do modify $ \st -> st { esDepth = esDepth st + 1 }
(newfunc,result) <- (unEFunc $ ehHandler e) msg
modify $ \st -> st { esDepth = esDepth st 1 }
updateEvent newfunc e
if result == EHContinue then runEvents' es else return result
updateEvent :: (Monad m, EventSocketIO h) => Maybe (EventHandlerFunc h m) -> EventHandler h m -> EventSocketT h m ()
updateEvent Nothing _ = return ()
updateEvent (Just newfunc) e = do
let isglobal = B.null uuid
eid@(_,uuid,et) = ehID e
updatefromsession sess = sess { sessEvents = M.update updf et $ sessEvents sess }
updf i = Just . flip S.map i $ \x ->
if ehID x == eid
then x { ehHandler = newfunc }
else x
if isglobal
then modify $ \est -> est { esGlobalSession = updatefromsession $ esGlobalSession est }
else modify $ \est -> est { esSessions = M.update (Just . updatefromsession) uuid $ esSessions est }
buildMessage :: (MonadIO m, EventSocketIO h) => (EvtKVMap, B.ByteString) -> EventSocketT h m EventSocketMessage
buildMessage (kvmap,msgdata) =
case M.lookup (B.pack "content-type") kvmap of
Nothing -> throwError . ProtocolError $ "No content-type in message."
Just ct | B.pack "api/response" == ct ->
let (success, dat) =
case msgdata of
_ | B.null msgdata -> (True, Left msgdata)
| '+' == B.head msgdata -> (True, Left msgdata)
| '-' == B.head msgdata -> (False, Left msgdata)
| otherwise -> (True, Right $ parseKVMap False msgdata)
in return EventSocketMessage {
esmType = E_APIResponse,
esmHeaders = kvmap,
esmSuccess = success,
esmData = dat
}
| B.pack "command/reply" == ct ->
case M.lookup (B.pack "reply-text") kvmap of
Nothing -> throwError . ProtocolError $ "No reply-text in command reply."
Just rt | B.null rt -> throwError . ProtocolError $ "Empty reply-text in command reply."
| '+' == B.head rt -> return True
| '-' == B.head rt -> return False
| otherwise -> throwError . ProtocolError $ "Could not parse reply-text in command reply."
>>= \success -> return EventSocketMessage {
esmType = E_CommandReply,
esmHeaders = kvmap,
esmSuccess = success,
esmData = Left msgdata
}
| B.pack "text/event-plain" == ct ->
let eventmap = parseKVMap False msgdata
in case M.lookup (B.pack "event-name") eventmap of
Nothing -> throwError . ProtocolError $ "No event-name in event headers."
Just en -> let eventtype = case reads ("E_" ++ B.unpack en) :: [(EventType,String)] of
[(et,[])] -> et
_ -> E_Other en
in return EventSocketMessage {
esmType = eventtype,
esmHeaders = kvmap,
esmSuccess = True,
esmData = Right eventmap
}
| B.pack "text/disconnect-notice" == ct ->
return EventSocketMessage {
esmType = E_End,
esmHeaders = kvmap,
esmSuccess = True,
esmData = Left msgdata
}
| otherwise -> throwError . ProtocolError $ "Unrecognized content-type."
readRawMessage :: (MonadIO m, EventSocketIO h) => EventSocketT h m (EvtKVMap, B.ByteString)
readRawMessage = do
msg <- readEvtKVMap False
content_length <- case M.lookup (B.pack "content-length") msg of
Nothing -> return 0
Just amt -> eBSToInt amt
msgdata <- if content_length > 0 then eRead content_length else return B.empty
when (content_length /= B.length msgdata) $
throwError . ProtocolError $ "Content-length mismatch with data received."
return (msg,msgdata)
readEvtKVMap :: (MonadIO m, EventSocketIO h) => Bool -> EventSocketT h m EvtKVMap
readEvtKVMap raw = do
h <- gets esHandle
ls <- readReply' h []
return . M.fromList $ map linetokv ls
where readReply' h st = do
l <- B.dropWhile (=='\r') `fmap` eReadLine
if B.null l then return st else readReply' h (B.takeWhile (/='\r') l:st)
linetokv i = B.map toLower *** fromJust . (if raw then Just else urlDecode) . B.dropWhile isSpace . B.drop 1 $ B.break (==':') i
eReadLine :: (MonadIO m, EventSocketIO h) => EventSocketT h m B.ByteString
eReadLine = do
st <- get
ml <- liftIO . Exc.try . esioBReadLine $ esHandle st
case ml of
Left (e :: IOError) -> throwError . NetworkError $ "Read line IO error: " ++ show e
Right l -> (dbug 5 $ if B.null l then "<--------------------" else "<-- " ++ show l) >> return l
eRead :: (MonadIO m, EventSocketIO h) => Int -> EventSocketT h m B.ByteString
eRead len = do
st <- get
md <- liftIO . Exc.try $ esioBRead (esHandle st) len
case md of
Left (e :: IOError) -> throwError . NetworkError $ "Read data IO error: " ++ show e
Right d -> (dbug 5 $ "<-- " ++ show d) >> return d
eBSToInt :: (MonadIO m, EventSocketIO h) => B.ByteString -> EventSocketT h m Int
eBSToInt s = case B.readInt s of
Nothing -> throwError . ParseError $ "Cannot convert integer to string."
Just (i,_) -> return i
eWrite :: (MonadIO m, EventSocketIO h) => B.ByteString -> EventSocketT h m ()
eWrite s = do
dbug 5 $ "--> " ++ show s
st <- get
result <- liftIO . Exc.try $ esioBWrite (esHandle st) s >> esioFlush (esHandle st)
case result of
Left (err :: IOError) -> throwError . NetworkError $ "Error writing or flushing: " ++ show err
Right _ -> return ()
dbug :: (MonadIO m, EventSocketIO h) => Int -> String -> EventSocketT h m ()
dbug lvl msg = do
est <- get
when (esDebugLevel est >= lvl) . liftIO . putStrLn $ "[DBG] " ++ msg
parseKVMap :: Bool -> B.ByteString -> EvtKVMap
parseKVMap raw = M.fromList . map (linetokv .fst . B.break (=='\r')) . B.lines
where
linetokv i = B.map toLower *** fromJust . (if raw then Just else urlDecode) . B.dropWhile isSpace . B.drop 1 $ B.break (==':') i
urlDecode :: B.ByteString -> Maybe B.ByteString
urlDecode s = maybe Nothing (Just . B.reverse . B.pack) $ urldecode' 0 []
where
slen = B.length s
charat p = B.index s p
urldecode' pos result | pos == slen = Just result
| B.index s pos == '%' = if (pos + 2) >= slen
then Nothing
else maybe Nothing (\i -> urldecode' (pos + 3) (i:result)) $
hdstoint (charat (pos + 1)) (charat (pos + 2))
| otherwise = urldecode' (pos + 1) (charat pos:result)
hdtoint c = let cl = ord $ toLower c
c0 = ord '0'
c9 = ord '9'
ca = ord 'a'
cf = ord 'f'
in if cl >= c0 && cl <= c9
then Just $ cl c0
else if cl >= ca && cl <= cf
then Just $ (cl ca) + 10
else Nothing
hdstoint c1 c2 = do
mc1 <- hdtoint c1
mc2 <- hdtoint c2
return . chr $ (mc1 * 16) + mc2
esRunActions :: (MonadIO m, EventSocketIO h)
=> [EventSocketCommand]
-> EventSocketT h m [EventSocketMessage]
esRunActions acts = concat `fmap` mapM esRun acts
esRun :: (MonadIO m, EventSocketIO h) => EventSocketCommand
-> EventSocketT h m [EventSocketMessage]
esRun CmdEvents { format = format, events = events } = do
sendAPI (B.pack "events") $ B.intercalate (B.singleton ' ') [format, B.intercalate (B.singleton ' ') events]
waitForEvent E_CommandReply
esRun CmdLinger = do
sendAPI (B.pack "linger") B.empty
waitForEvent E_CommandReply
esRun CmdFilter { isDelete = isdelete, eventHeader = eventheader, eventValue = eventvalue } = do
let filtercmd | isdelete = B.unwords [B.pack "delete ", eventheader, eventvalue]
| otherwise = B.unwords [eventheader, eventvalue]
commandAndReply (B.pack "filter") filtercmd
esRun (CmdSet k v) = commandAndReply (B.pack "set") $ B.intercalate (B.singleton '=') [k,v]
esRun CmdHangup { reason = v } = sendCommand (B.pack "hangup") v >> waitForEvent E_CHANNEL_HANGUP_COMPLETE
esRun CmdSleep { duration = v } = commandAndReply (B.pack "sleep") . B.pack . show $ v
esRun CmdAnswer = commandAndReply (B.pack "answer") B.empty
esRun c@CmdPlayGather {} =
let x = B.intercalate (B.singleton ' ') [B.pack . show $ minDigits c,
B.pack . show $ maxDigits c,
B.pack . show $ tries c,
B.pack . show $ timeout c * 1000,
terminators c,
file c,
invalidFile c,
varName c,
regexp c]
in commandAndReply (B.pack "play_and_get_digits") x
esRun CmdBridge { destinations = ds } = commandAndReply (B.pack "bridge") $ B.intercalate (B.singleton ',') ds
esRun CmdSay { text = text } = commandAndReply (B.pack "say") text
esRun CmdSpeak { text = text } = commandAndReply (B.pack "speak") text
esRun CmdRecord { filename = filename, maxLength = len } =
commandAndReply (B.pack "record") $ B.intercalate (B.singleton ' ') [filename, B.pack $ show len ]
esRun CmdMetaApp { listenKey = listenkey, listenTo = listento, respondOn = respondon, appString = appstring } =
commandAndReply (B.pack "bind_meta_app") $ B.unwords [B.singleton listenkey, B.singleton listento, B.singleton respondon,
appstring]
esRun CmdPlay { filename = fn } = commandAndReply (B.pack "play") fn
esRun CmdSync = syncPoint