{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
module DMCC.Agent
where
import DMCC.Prelude
import Control.Lens
import Control.Concurrent.STM (retry)
import Data.Aeson as A
import Data.Aeson.TH
import Data.CaseInsensitive (original)
import Data.Data
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client (httpNoBody, method, requestBody)
import DMCC.Session
import DMCC.Types
import DMCC.Util ()
import qualified DMCC.XML.Request as Rq
import qualified DMCC.XML.Response as Rs
data Action = MakeCall{number :: Extension}
| AnswerCall{callId :: CallId}
| EndCall{callId :: CallId}
| HoldCall{callId :: CallId}
| RetrieveCall{callId :: CallId}
| BargeIn{callId :: CallId, pType :: ParticipationType}
| ConferenceCall{activeCall :: CallId, heldCall :: CallId}
| TransferCall{activeCall :: CallId, heldCall :: CallId}
| SendDigits{callId :: CallId, digits :: Text}
| SetState{newState :: SettableAgentState}
deriving Show
$(deriveJSON
defaultOptions{sumEncoding = defaultTaggedObject{tagFieldName="action"}}
''Action)
data AgentSnapshot = AgentSnapshot
{ _calls :: Map.Map CallId Call
, _state :: (Maybe AgentState, Text)
}
deriving Show
instance ToJSON AgentSnapshot where
toJSON s =
object [ "calls" A..= Map.mapKeys (\(CallId t) -> t) (_calls s)
, "state" A..= _state s
]
instance FromJSON AgentSnapshot where
parseJSON (Object o) =
AgentSnapshot
<$> Map.mapKeys CallId `liftM` (o .: "calls")
<*> (o .: "state")
parseJSON _ = fail "Could not parse AgentSnapshot from non-object"
$(makeLenses ''AgentSnapshot)
data AgentEvent = TelephonyEvent
{ dmccEvent :: Rs.Event
, newSnapshot :: AgentSnapshot
}
| StateChange{newSnapshot :: AgentSnapshot}
| TelephonyEventError{errorText :: String}
| RequestError{errorText :: String}
deriving Show
$(deriveJSON defaultOptions ''AgentEvent)
data WHEvent = WHEvent
{ agentId :: AgentId
, event :: AgentEvent
}
deriving Show
$(deriveJSON defaultOptions ''WHEvent)
data Agent = Agent
{ deviceId :: DeviceId
, monitorId :: Text
, actionChan :: TChan Action
, actionThread :: ThreadId
, rspChan :: TChan Rs.Response
, rspThread :: ThreadId
, stateThread :: ThreadId
, eventChan :: TChan AgentEvent
, snapshot :: TVar AgentSnapshot
}
instance Show Agent where
show (Agent (DeviceId d) m _ _ _ _ _ _ _) =
"Agent{deviceId=" <> unpack (original d) <>
", monitorId=" <> unpack m <>
"}"
newtype AgentHandle = AgentHandle (AgentId, Session)
instance Ord AgentHandle where
compare (AgentHandle (aid1, _)) (AgentHandle (aid2, _)) = compare aid1 aid2
instance Eq AgentHandle where
(AgentHandle (aid1, _)) == (AgentHandle (aid2, _)) = aid1 == aid2
instance Show AgentHandle where
show (AgentHandle (aid, _)) = show aid
data AgentError
= DeviceError String
| MonitoringError String
| StatePollingError String
| UnknownAgent AgentId
deriving (Data, Typeable, Show)
instance (Exception AgentError)
agentAction :: (MonadLoggerIO m, MonadCatch m) => Action -> AgentHandle -> m ()
agentAction cmd (AgentHandle (aid, as)) = do
ags <- readTVarIO $ agents as
case Map.lookup aid ags of
Just Agent{..} -> atomically $ writeTChan actionChan cmd
Nothing -> throwIO $ UnknownAgent aid
placeAgentLock :: AgentHandle -> STM ()
placeAgentLock (AgentHandle (aid, as)) =
modifyTVar' (agentLocks as) (Set.insert aid)
releaseAgentLock :: MonadLoggerIO m => AgentHandle -> m ()
releaseAgentLock (AgentHandle (aid, as)) =
atomically $ modifyTVar' (agentLocks as) (Set.delete aid)
controlAgent :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadMask m)
=> SwitchName
-> Extension
-> Session
-> m (Either AgentError AgentHandle)
controlAgent switch ext as = do
let aid = AgentId (switch, ext)
ah = AgentHandle (aid, as)
prev <- atomically $ do
locks <- readTVar $ agentLocks as
if Set.member aid locks
then retry
else do ags <- readTVar $ agents as
if Map.member aid ags
then pure $ Just aid
else placeAgentLock ah >> pure Nothing
case prev of
Just a -> pure $ Right $ AgentHandle (a, as)
Nothing -> try $ flip onException (releaseAgentLock ah) $
do
gdiRsp <-
sendRequestSync (dmccHandle as) Nothing
Rq.GetDeviceId
{ switchName = switch
, extension = ext
}
device <-
case gdiRsp of
Just (Rs.GetDeviceIdResponse device) ->
pure device
Just (Rs.CSTAErrorCodeResponse errorCode) ->
throwIO $ DeviceError $ unpack errorCode
_ ->
throwIO $ DeviceError "Bad GetDeviceId response"
msrRsp <-
sendRequestSync (dmccHandle as) Nothing
Rq.MonitorStart
{ acceptedProtocol = protocolVersion as
, monitorRq = Rq.Device device
}
monitorCrossRefID <-
case msrRsp of
Just (Rs.MonitorStartResponse monitorCrossRefID) ->
pure monitorCrossRefID
Just (Rs.CSTAErrorCodeResponse errorCode) ->
throwIO $ MonitoringError $ unpack errorCode
_ ->
throwIO $ DeviceError "Bad MonitorStart response"
snapshot <- newTVarIO $ AgentSnapshot Map.empty (Nothing, "")
actionChan <- newTChanIO
actionThread <-
forkIO $ forever $
atomically (readTChan actionChan) >>=
processAgentAction aid device snapshot as
eventChan <- newBroadcastTChanIO
rspChan <- newTChanIO
rspThread <-
forkIO $ forever $
atomically (readTChan rspChan) >>=
processAgentEvent aid device snapshot eventChan as
gsRsp' <-
sendRequestSync (dmccHandle as) (Just aid)
Rq.GetAgentState
{ device = device
, acceptedProtocol = protocolVersion as
}
case gsRsp' of
Just Rs.GetAgentStateResponse{..} ->
atomically $ modifyTVar' snapshot $ state .~ (agentState, reasonCode)
Just (Rs.CSTAErrorCodeResponse errorCode) ->
throwIO $ StatePollingError $ unpack errorCode
_ ->
throwIO $ DeviceError "Bad GetAgentState response"
stateThread <-
forkIO $ forever $ do
gsRsp <- sendRequestSync (dmccHandle as) (Just aid)
Rq.GetAgentState
{ device = device
, acceptedProtocol = protocolVersion as
}
case gsRsp of
Just Rs.GetAgentStateResponse{..} -> do
ns <- atomically $ do
sn <- readTVar snapshot
if _state sn /= (agentState, reasonCode)
then do modifyTVar' snapshot (state .~ (agentState, reasonCode))
newSnapshot <- readTVar snapshot
Just newSnapshot <$ writeTChan eventChan (StateChange newSnapshot)
else pure Nothing
case (ns, webHook as) of
(Just ns', Just connData) -> sendWH connData aid $ StateChange ns'
_ -> pure ()
_ -> pure ()
threadDelay $ statePollingDelay (sessionOptions $ dmccHandle as) * 1000000
let ag = Agent
device
monitorCrossRefID
actionChan
actionThread
rspChan
rspThread
stateThread
eventChan
snapshot
atomically $ modifyTVar' (agents as) $ Map.insert aid ag
releaseAgentLock ah
pure ah
processAgentAction :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)
=> AgentId
-> DeviceId
-> TVar AgentSnapshot
-> Session
-> Action
-> m ()
processAgentAction aid@(AgentId (switch, _)) device snapshot as action =
case action of
MakeCall toNumber -> do
rspDest <-
sendRequestSync (dmccHandle as) (Just aid)
Rq.GetThirdPartyDeviceId
{ switchName = switch
, extension = toNumber
}
case rspDest of
Just (Rs.GetThirdPartyDeviceIdResponse destDev) -> do
mcr <- sendRequestSync (dmccHandle as) (Just aid) $
Rq.MakeCall
device
destDev
(protocolVersion as)
case mcr of
Just (Rs.MakeCallResponse callId ucid) -> do
now <- liftIO getCurrentTime
let call = Call Out ucid now [destDev] Nothing False False
atomically $ modifyTVar' snapshot $ calls %~ Map.insert callId call
_ -> pure ()
_ -> pure ()
AnswerCall callId -> simpleRequest Rq.AnswerCall callId
HoldCall callId -> simpleRequest Rq.HoldCall callId
RetrieveCall callId -> simpleRequest Rq.RetrieveCall callId
BargeIn activeCall m -> do
sscR <- sendRequestSync (dmccHandle as) (Just aid) $
Rq.SingleStepConferenceCall
device
activeCall
(protocolVersion as)
m
case sscR of
Just (Rs.SingleStepConferenceCallResponse callId) -> do
allCalls <- atomically $ do
agents <- readTVar (agents as)
mapM (fmap _calls . readTVar . DMCC.Agent.snapshot) $ Map.elems agents
case Map.lookup callId (Map.unions allCalls) of
Just call ->
atomically $ modifyTVar' snapshot $ calls %~ Map.insert callId call
_ -> pure ()
_ -> pure ()
ConferenceCall activeCall heldCall ->
simpleRequest2 Rq.ConferenceCall activeCall heldCall
TransferCall activeCall heldCall ->
simpleRequest2 Rq.TransferCall activeCall heldCall
EndCall callId -> simpleRequest Rq.ClearConnection callId
SendDigits{..} ->
void $
sendRequestSync (dmccHandle as) (Just aid) $
Rq.GenerateDigits digits device callId (protocolVersion as)
SetState newState -> do
cs <- atomically $ readTVar snapshot
when (fst (_state cs) /= Just Busy) $
simpleRequest Rq.SetAgentState newState
where
arq = sendRequestAsync (dmccHandle as) $ Just aid
simpleRequest rq arg = arq $ rq device arg $ protocolVersion as
simpleRequest2 rq arg1 arg2 = arq $ rq device arg1 arg2 $ protocolVersion as
processAgentEvent :: (MonadUnliftIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadCatch m)
=> AgentId
-> DeviceId
-> TVar AgentSnapshot
-> TChan AgentEvent
-> Session
-> Rs.Response
-> m ()
processAgentEvent aid device snapshot eventChan as rs = do
now <- liftIO getCurrentTime
case rs of
Rs.CSTAErrorCodeResponse err ->
atomically $ writeTChan eventChan $ RequestError $ unpack err
Rs.EventResponse _ ev@Rs.OriginatedEvent{..} -> do
s <- readTVarIO snapshot
updSnapshot' <-
if Map.member callId $ _calls s
then pure s
else do gcldr <-
sendRequestSync (dmccHandle as) (Just aid) $
Rq.GetCallLinkageData device callId (protocolVersion as)
case gcldr of
Just (Rs.GetCallLinkageDataResponse ucid) ->
atomically $ do
let call = Call Out ucid now [calledDevice] Nothing False False
modifyTVar' snapshot $ calls %~ Map.insert callId call
readTVar snapshot
_ -> do
atomically $ writeTChan eventChan $
TelephonyEventError "Bad GetCallLinkageDataResponse"
pure s
atomically $ writeTChan eventChan $ TelephonyEvent ev s
case webHook as of
Just connData -> sendWH connData aid $ TelephonyEvent ev updSnapshot'
_ -> pure ()
Rs.EventResponse _ ev -> do
(updSnapshot, report) <- atomically $ do
report <- case ev of
Rs.OriginatedEvent{..} ->
pure True
Rs.DeliveredEvent{..} -> do
s <- readTVar snapshot
if Map.member callId $ _calls s
then pure False
else
True <$ modifyTVar' snapshot (calls %~ Map.insert callId call)
where
call = Call dir ucid now [interloc] Nothing False False
(dir, interloc) = if callingDevice == device
then (Out, calledDevice)
else (In distributingVdn, callingDevice)
Rs.DivertedEvent{..} -> do
modifyTVar' snapshot $ calls %~ at callId .~ Nothing
pure True
Rs.EstablishedEvent{..} -> do
callOperation callId
(\call -> Map.insert callId call{answered = Just now})
"Established connection to an undelivered call"
pure True
Rs.FailedEvent{..} -> do
callOperation callId
(\call -> Map.insert callId call{failed = True})
"Failed an unknown call"
pure True
Rs.ConnectionClearedEvent{..} -> do
let really = releasingDevice == device
when really $ modifyTVar' snapshot $ calls %~ at callId .~ Nothing
pure really
Rs.HeldEvent{..} -> do
callOperation callId
(\call -> Map.insert callId call{held = True})
"Held an undelivered call"
pure True
Rs.RetrievedEvent{..} -> do
callOperation callId
(\call -> Map.insert callId call{held = False})
"Retrieved an undelivered call"
pure True
Rs.ConferencedEvent prim sec -> do
s <- readTVar snapshot
case (Map.lookup prim $ _calls s, Map.lookup sec $ _calls s) of
(Just oldCall, Just newCall) -> do
modifyTVar' snapshot $ calls %~ at prim .~ Nothing
let callHandler call =
Map.insert sec
call{interlocutors = interlocutors oldCall <> interlocutors newCall}
callOperation sec callHandler "Conferenced an undelivered call"
pure True
_ -> pure False
Rs.TransferedEvent prim sec -> do
modifyTVar' snapshot $ calls %~ at prim .~ Nothing
modifyTVar' snapshot $ calls %~ at sec .~ Nothing
pure True
Rs.UnknownEvent -> pure False
s <- readTVar snapshot
when report $ writeTChan eventChan $ TelephonyEvent ev s
pure (s, report)
case (webHook as, report) of
(Just connData, True) -> sendWH connData aid $ TelephonyEvent ev updSnapshot
_ -> pure ()
_ -> pure ()
where
callOperation :: CallId
-> (Call -> Map.Map CallId Call -> Map.Map CallId Call)
-> String
-> STM ()
callOperation callId callMod err = do
s <- readTVar snapshot
case Map.lookup callId $ _calls s of
Just call -> modifyTVar' snapshot $ \m -> m & calls %~ callMod call
Nothing -> writeTChan eventChan $ TelephonyEventError err
sendWH :: (MonadUnliftIO m, MonadLoggerIO m, MonadCatch m)
=> (HTTP.Request, HTTP.Manager)
-> AgentId
-> AgentEvent
-> m ()
sendWH (req, mgr) aid payload =
handle errHandler $ void $ liftIO $ httpNoBody req{requestBody = rqBody, method = "POST"} mgr
where
rqBody = HTTP.RequestBodyLBS $ A.encode $ WHEvent aid payload
errHandler (e :: HTTP.HttpException) = logErrorN $ pack $
"Webhook error for agent " <> show aid <> ", event " <> show payload <> ": " <> show e
releaseAgent :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)
=> AgentHandle -> m ()
releaseAgent ah@(AgentHandle (aid, as)) = do
prev <- atomically $ do
locks <- readTVar $ agentLocks as
if Set.member aid locks
then retry
else do ags <- readTVar $ agents as
case Map.lookup aid ags of
Just ag -> placeAgentLock ah >> pure (Just ag)
Nothing -> pure Nothing
case prev of
Nothing -> throwIO $ UnknownAgent aid
Just ag ->
handle (\e -> releaseAgentLock ah >> throwIO (e :: IOException)) $ do
killThread (actionThread ag)
killThread (rspThread ag)
killThread (stateThread ag)
_ <- sendRequestSync (dmccHandle as) (Just aid)
Rq.MonitorStop
{ acceptedProtocol = protocolVersion as
, monitorCrossRefID = monitorId ag
}
_ <- sendRequestSync (dmccHandle as) (Just aid)
Rq.ReleaseDeviceId{device = deviceId ag}
atomically $ modifyTVar' (agents as) (Map.delete aid)
releaseAgentLock ah
pure ()
handleEvents :: (MonadLoggerIO m, MonadThrow m) => AgentHandle -> (AgentEvent -> m ()) -> m ThreadId
handleEvents (AgentHandle (aid, as)) handler = do
ags <- atomically $ readTVar $ agents as
case Map.lookup aid ags of
Nothing -> throwIO $ UnknownAgent aid
Just Agent{..} -> do
sub <- atomically $ dupTChan eventChan
forever $ handler =<< atomically (readTChan sub)
getAgentSnapshot :: (MonadLoggerIO m, MonadThrow m) => AgentHandle -> m AgentSnapshot
getAgentSnapshot (AgentHandle (aid, as)) = do
ags <- readTVarIO $ agents as
case Map.lookup aid ags of
Nothing -> throwIO $ UnknownAgent aid
Just Agent{..} -> readTVarIO snapshot