EventSocket-0.1: Network/EventSocket.hs

{-# 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 ()


-}