{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} {- | This module provides an interface for the FreeSwitch event socket - . Developed by David Austin () Released to the Open Source Software community by Teliax Inc () -} module Network.EventSocket ( -- * Types -- ** Messages EventSocketMessage(..) -- ** Base types ,EventSocketState ,EventType(..) ,EventSocketError(..) ,EventSocketCommand(..) ,SessionState(sessUUID,sessVariables) ,EvtKVMap ,ESUUID ,EventSocketT ,EventSocketIO(..) -- ** Classes -- * Provided functions -- ** Utility functions ,startEventSocket ,connectInbound ,runEventSocketT -- ** Settings modification ,modifySyncMode ,modifyDebugLevel -- ** Events ,registerEventHandler ,unregisterEventHandler ,EventId ,EventHandlerResult(..) ,EventHandlerFunc(..) -- ** Highlevel functions ,syncPoint ,esRun ,esRunActions ,getSession -- ** Midlevel functions ,apiAndReply ,commandAndReply ,withUUID ,getUUID -- ** Low level functions ,sendAPI ,sendCommand ,waitForEvent ,eventSocketReadEventsUntil ,newEventSocketState -- * Examples -- ** Simple example -- $example ) 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 ()))" {- | Mainly FreeSwitch events. More information for FreeSwitch-specific events: -} data EventType -- | Sent when the initial negotiation is done. = E_Start -- | Sent when ending. | E_End -- | Sent when the Freeswitch event name could not be parsed. | E_Other B.ByteString -- | FreeSwitch API reply. | E_APIResponse -- | FreeSwitch command reply. | 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) {- | Event Socket commands. This list is far from complete. More information is available: -} data EventSocketCommand -- | = CmdEvents { format :: B.ByteString -- ^ Event format, either plain or XML. , events :: [B.ByteString] -- ^ Event types. } -- | | CmdFilter { isDelete :: Bool -- ^ Delete this filter instead of creating. , eventHeader :: B.ByteString -- ^ Header to allow. , eventValue :: B.ByteString -- ^ Value to allow. } -- | Turns on event socket linger, causing the event socket to send all remaining events before closing the connection. | CmdLinger -- | Sets a channel variable. | CmdSet { key :: B.ByteString -- ^ Set key. , val :: B.ByteString -- ^ Set value. } -- | Hangs up the call. (Uses the UUID in the event socket state.) | CmdHangup { reason :: B.ByteString -- ^ Reason for hangup: } -- | Sleeps the specified number of milliseconds. | CmdSleep { duration :: Int -- ^ Duration to sleep. } -- | Answers the call. | CmdAnswer -- | Plays a sound file and waits for input. | CmdPlayGather { minDigits :: Int, maxDigits :: Int, tries :: Int, timeout :: Int, terminators :: B.ByteString, file :: B.ByteString, invalidFile :: B.ByteString, varName :: B.ByteString, regexp :: B.ByteString } -- | Bridges a call. | CmdBridge { destinations :: [B.ByteString] } -- | Can speak simple output like digits or time. | CmdSay { text :: B.ByteString } -- | Can speak arbitrary text using a TTS engine. | CmdSpeak { text :: B.ByteString } -- | Plays a sound file. | CmdPlay { filename :: B.ByteString } -- | Records a sound file. | CmdRecord { filename :: B.ByteString, maxLength :: Int } -- | Binds a meta application. | CmdMetaApp { listenKey, listenTo, respondOn :: Char, appString :: B.ByteString } -- | Sync point. | CmdSync deriving Show -- | The state of the event socket connection. data EventSocketIO h => EventSocketState h m = EventSocketState { -- | Eventsocket should continue running. esRunning :: Bool -- | Usually a network socket. , esHandle :: h -- | Hostname for incoming connection. , esHostName :: HostName -- | Port for incoming connection. , esPortNumber :: PortNumber -- | Pending events. Used internally. , esEvents :: [EventSocketMessage] -- | Use \"event-lock: true\" in outgoing commands. , esSyncMode :: Bool -- | Run event handlers for incoming events. , esHandleEvents :: Bool -- | Currently used UUID. Set from the initial response to connect, and possibly changed later. , esUUID :: B.ByteString -- | Sequence number used for generating events or other session-unique identifiers. , esSeq :: Int -- | Sessions. , esSessions :: M.Map B.ByteString (SessionState h m) -- | The global session. (Used for global events, etc.) , esGlobalSession :: SessionState h m -- | Recursion depth, used for detecting nested eventSocketReadEventsUntil calls. , esDepth :: Int , esDebugLevel :: Int } deriving Show {- | Stores a session. Two user accessible fields exist: * sessUUID :: 'ESUUID' -- The UUID this session is associated with. * sessVariables :: 'EvtKVMap' -- Variables associated with this channel, updated when receiving CHANNEL_DATA events from FreeSwitch. -} 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) -- | Error type thrown when something goes boom. data EventSocketError = UnknownError | NetworkError String | ParseError String | ProtocolError String | GeneralError String deriving Show -- | Basically, an event. Used and returned by some of the lower level Eventsocket routines. data EventSocketMessage = EventSocketMessage { -- | Type of the event. esmType :: EventType, -- | The headers FreeSwitch sent. esmHeaders :: EvtKVMap, -- | Is this a positive response? esmSuccess :: Bool, -- | Either a ByteString or a parsed KV map depending on the type of response. esmData :: Either B.ByteString EvtKVMap } deriving (Show,Eq,Ord) instance Error EventSocketError where noMsg = UnknownError -- | UUIDs are currently just bytestrings. type ESUUID = B.ByteString -- | Just a simple map ByteString to ByteString. type EvtKVMap = M.Map B.ByteString B.ByteString -- | You may instance this class if you'd like to use a different handle type (or just read/write to the normal Handle in some special way.) class EventSocketIO h where esioBReadLine :: h -> IO B.ByteString -- ^ Read one line from the handle. esioBRead :: h -> Int -> IO B.ByteString -- ^ Read a specified amount of bytes from the handle. esioBWrite :: h -> B.ByteString -> IO () -- ^ Write to the handle esioFlush :: h -> IO () -- ^ Flush the handle. esioReady :: h -> IO Bool -- ^ Check if the handle is ready for reading. -- | There exists a default instance for Handle. instance EventSocketIO Handle where esioBReadLine = B.hGetLine esioBRead = B.hGet esioBWrite = B.hPutStr esioFlush = hFlush esioReady = hReady -- | Runs the event socket monad transformer. runEventSocketT :: (MonadIO m, EventSocketIO h) => EventSocketT h m a -- ^ Monadic action to run. -> EventSocketState h m -- ^ Initial state (possibly from 'newEventSocketState') -> m (Either EventSocketError a, (EventSocketState h m)) -- ^ Returns a tuple with either the final result or error, and the ending state. runEventSocketT (EventSocketT ma) = runStateT (runErrorT ma) -- | Basic listen socket creation. 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 -- | Basic example accept loop. 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 () -- | Starts a listen socket for incoming EventSocket connections. You'll generally want to call 'connectInbound' after the handler is triggered. startEventSocket :: HostName -- ^ Hostname to listen on. -> PortNumber -- ^ Port number to listen on. -> (EventSocketState Handle m -> IO ()) -- ^ Action to run on each incoming connection. -> 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 -- | Creates a new EventSocketState. You may use your own handle type and functions for reading and writing data to it. newEventSocketState :: EventSocketIO h => h -- ^ Connection handle. -> HostName -- ^ Hostname of incoming connection -> PortNumber -- ^ Port of incoming connection. -> EventSocketState h m -- ^ New state. 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 } -- | SyncMode controls whether "Event-Lock: true" is sent with commands. modifySyncMode :: (Monad m, EventSocketIO h) => (Bool -> Bool) -> EventSocketT h m Bool modifySyncMode f = modify (\est -> est { esSyncMode = f $ esSyncMode est }) >> get >>= return . esSyncMode -- | Modifies the debug level. At high values, the event socket library will spit out massive amounts of data to the console. modifyDebugLevel :: (Monad m, EventSocketIO h) => (Int -> Int) -> EventSocketT h m Int modifyDebugLevel f = modify (\est -> est { esDebugLevel = f $ esDebugLevel est }) >> get >>= return . esDebugLevel -- | Given an event ID, it will remove that event if it exists. unregisterEventHandler :: (Monad m, EventSocketIO h) => EventId -- ^ Event ID to unregister. -> 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 } {- | Registers an event handler. If the UUID is left blank, it will trigger globally on all events of the appropriate type. Some event types (example E_CommandReply, E_APIResponse) do not have a UUID and therefore must be added as an global event if you wish to catch it. Since the event may return a new handler function on each invocation, an event handler may maintain private state this way. The event handler may return EHContinue to continue processing, EHStopEvents to stop processing events for that message or EHStopReading to exit the event reading loop entirely. Event handlers are only called from within 'eventSocketReadEventsUntil' (and functions that use this: 'waitForEvent', 'commandAndReply', 'apiAndReply'). Global events are processed first, then session events. You may not recurse into 'eventSocketReadEventUntil' from within an event handler. -} registerEventHandler :: (MonadIO m, EventSocketIO h) => B.ByteString -- ^ UUID for event handler, blank for globalr. -> EventType -- ^ Type of event to trigger on. -> Int -- ^ Priority, with lower events processed earlier. -> EventHandlerFunc h m -- ^ Event handler. -> EventSocketT h m EventId -- ^ Returns new Event ID. 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 {- | Run a monadic action with the specified UUID as the current UUID. Once the action completes, the previous UUID is restored iff it is the same as the original UUID. -} withUUID :: (Monad m, EventSocketIO h) => B.ByteString -- ^ UUID to use. -> (EventSocketT h m a) -- ^ Monadic action to run. -> 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 -- | Waits forever for the specified event type. waitForEvent :: (MonadIO m, EventSocketIO h) => EventType -- ^ Event type to wait for. -> EventSocketT h m [EventSocketMessage] -- ^ Returns a list of messages up to and include the the ending event. 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 -- | Sends a command and then waits for a response. commandAndReply :: (MonadIO m, EventSocketIO h) => B.ByteString -- ^ Command name. -> B.ByteString -- ^ Command arguments. (Blank if none.) -> 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 -- | Sends a command to the event socket. sendCommand :: (MonadIO m, EventSocketIO h) => B.ByteString -- ^ Command name. -> B.ByteString -- ^ Command arguments. -> 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) -- | Sends a raw command (such as an API command) to the event socket and waits for the response. apiAndReply :: (MonadIO m, EventSocketIO h) => B.ByteString -- ^ API action name. -> B.ByteString -- ^ API action arguments. -> 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 -- | Sends a raw command to the event socket. sendAPI :: (MonadIO m, EventSocketIO h) => B.ByteString -- ^ API action name. -> B.ByteString -- ^ API action arguments. -> 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 -- | Sends the initial connect message and receives a response. 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 } -- | Plays a 0 length tone stream to force a CHANNEL_EXECUTE_COMPLETE event as a synchronization point. Will wait forever if events aren't turned on. 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 {- | Reads messages from the event socket until a condition is true. The handler is called with Nothing to detect whether messages should be read (for example, check if the socket has data waiting.) At that point, the handler returns whether more messages should be read (True for more messages, False to stop reading messages.) The handler is called on each received message. At that the handler returns whether it is done (True for no more messages, False to continue reading messages.) -} eventSocketReadEventsUntil :: (MonadIO m, EventSocketIO h) => (Maybe EventSocketMessage -> EventSocketT h m Bool) -- ^ Condition function. -> 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 } -- | Gets a session if it exists. getSession :: (MonadIO m, EventSocketIO h) => ESUUID -- ^ UUID to look for. If blank, uses the main UUID. -> EventSocketT h m (Maybe (SessionState h m)) -- ^ Returns the session wrapped in Maybe. getSession uuid = do est <- get let euuid = if B.null uuid then esUUID est else uuid return $ M.lookup euuid $ esSessions est -- | Get the UUID of the main session. 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 -- | Runs a sequence of `EventSocketCommand's. esRunActions :: (MonadIO m, EventSocketIO h) => [EventSocketCommand] -- ^ List of commands to perform. -> EventSocketT h m [EventSocketMessage] -- ^ Result is all messages returned. esRunActions acts = concat `fmap` mapM esRun acts -- | Runs a command of type 'EventSocketCommand'. Behaves roughly the same as 'commandAndReply'. esRun :: (MonadIO m, EventSocketIO h) => EventSocketCommand -- ^ Command to run. -> EventSocketT h m [EventSocketMessage] -- ^ List of messages up to the terminating command reply or API response. 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 {- $example This example will accept an incoming Event Socket connection and play a message using the FLITE module. It is quite simple and doesn't look at the responses when it sends commands. An example of using both the low level and higher level esRun\/esRunActions interface is shown. > module TestApp where > > import qualified Data.ByteString.Char8 as B > import Control.Monad.State > import Control.Monad.Error > import Network.EventSocket > import IO > > -- Example of using StateT with EventSocketT. > type TestMonad a = EventSocketT Handle InnerMonad a > type InnerMonad = StateT TestState IO > > data TestState = TestState { meep :: Int } deriving Show > > -- Entry point for when FreeSwitch makes an event socket connection to the program. > -- You can also handle your own network connections and use newEventSocketState to create state to use here. > testThread :: EventSocketState Handle InnerMonad -> IO () > testThread est = do > let inistate = TestState { meep = 1 } > result <- runStateT (runEventSocketT testHandler est) inistate > putStrLn $ "*** Completion: " ++ show result > > -- Example of an event handler. > testEvent :: (MonadIO m, EventSocketIO h) => EventSocketMessage -> EventSocketT h m (Maybe (EventHandlerFunc h m), EventHandlerResult) > testEvent m = do > liftIO . putStrLn $ "Got event: " ++ show m > return (Just $ EventHandlerFunc testEvent,EHContinue) > testEvent :: EventSocketMessage -> TestMonad (Maybe (EventHandlerFunc h m),EventHandlerResult) > testEvent m = do > liftIO . putStrLn $ "Got event: " ++ show m > return (EventHandlerFunc testEvent,EHContinue) > > -- Example of using the low level interface. > doCallStuffLowLevel :: TestMonad [EventSocketMessage] > doCallStuffLowLevel = do > sendAPI (B.pack "linger") B.empty > waitForEvent E_CommandReply > sendAPI (B.pack "events plain all") B.empty > waitForEvent E_CommandReply > commandAndReply (B.pack "answer") B.empty > commandAndReply (B.pack "set") $ B.pack "tts_engine=flite" > commandAndReply (B.pack "set") $ B.pack "tts_voice=kal" > commandAndReply (B.pack "speak") $ B.pack "Riveting tale, chap." > > -- Example of using the high level interface. > doCallStuffHighLevel :: TestMonad [EventSocketMessage] > doCallStuffHighLevel = do > esRunActions [ CmdLinger > , CmdEvents { format = B.pack "plain", events = [B.pack "all"] } > , CmdAnswer > , CmdSet { key = B.pack "tts_engine", val = B.pack "flite" } > , CmdSet { key = B.pack "tts_voice", val = B.pack "kal" } > ] > esRun CmdSpeak { text = B.pack "Riveting tale, chap." } -- Example of running a single action. > > testHandler :: TestMonad () > testHandler = do > st <- lift get -- Must lift to get to our state. > registerEventHandler B.empty E_COMMAND 0 $ EventHandlerFunc testEvent -- Global event handler, triggering on all COMMAND events at priority 0. > inimsg <- connectInbound > when (meep st == 1) . liftIO $ putStrLn "Meep." > doCallStuffHighLevel > return () > > main :: IO () > main = do > startEventSocket "127.0.0.1" (fromIntegral 8984) testThread > return () -}