EventSocket (empty) → 0.1
raw patch · 4 files changed
+1085/−0 lines, 4 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, haskell98, mtl, network
Files
- EventSocket.cabal +14/−0
- LICENSE +9/−0
- Network/EventSocket.hs +1060/−0
- Setup.hs +2/−0
+ EventSocket.cabal view
@@ -0,0 +1,14 @@+Name: EventSocket +Version: 0.1+Author: Vulpyne @ Teliax +Maintainer: vulpyne+haskelleventsocket@teliax.com+Synopsis: Interfaces with FreeSwitch Event Socket.+Description: Interfaces with FreeSwitch Event Socket. This should be considered an alpha release and has not been tested extensively.+License: BSD3+License-file: LICENSE+Category: Network+Build-Type: Simple+Build-Depends:+ base >= 3 && < 5, network, haskell98, bytestring, mtl, containers+Exposed-Modules:+ Network.EventSocket
+ LICENSE view
@@ -0,0 +1,9 @@+Copyright (c) 2009, David Austin+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.+Neither the name of Teliax Inc nor the names of its contributors may 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 HOLDER 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.
+ Network/EventSocket.hs view
@@ -0,0 +1,1060 @@+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}+{- |+ This module provides an interface for the FreeSwitch event socket - <http://wiki.freeswitch.org/wiki/Event_Socket>.++ Developed by David Austin (<mailto:vulpyne+haskelleventsocket@teliax.com>)++ Released to the Open Source Software community by Teliax Inc (<http://www.teliax.com/>)+-}+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: <http://wiki.freeswitch.org/wiki/Event_list>+-}+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: <http://wiki.freeswitch.org/wiki/Command_reference>+-}+data EventSocketCommand+ -- | <http://wiki.freeswitch.org/wiki/Event_Socket#event>+ = CmdEvents { format :: B.ByteString -- ^ Event format, either plain or XML.+ , events :: [B.ByteString] -- ^ Event types.+ }+ -- | <http://wiki.freeswitch.org/wiki/Event_Socket#filter>+ | 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: <http://wiki.freeswitch.org/wiki/Hangup_causes>+ }+ -- | Sleeps the specified number of milliseconds. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_sleep>+ | CmdSleep {+ duration :: Int -- ^ Duration to sleep.+ }+ -- | Answers the call.+ | CmdAnswer+ -- | Plays a sound file and waits for input. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_play_and_get_digits>+ | 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. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_bridgecall>+ | CmdBridge { destinations :: [B.ByteString] }+ -- | Can speak simple output like digits or time. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_say>+ | CmdSay { text :: B.ByteString }+ -- | Can speak arbitrary text using a TTS engine. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_speak>+ | CmdSpeak { text :: B.ByteString }+ -- | Plays a sound file. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_playback>+ | CmdPlay { filename :: B.ByteString }+ -- | Records a sound file. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_record>+ | CmdRecord { filename :: B.ByteString, maxLength :: Int }+ -- | Binds a meta application. <http://wiki.freeswitch.org/wiki/Misc._Dialplan_Tools_bind_meta_app>+ | 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 ()+++-}+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain