dmcc (empty) → 1.0.0.0
raw patch · 18 files changed
+2788/−0 lines, 18 filesdep +HsOpenSSLdep +aesondep +base
Dependencies added: HsOpenSSL, aeson, base, binary, bytestring, case-insensitive, classy-prelude, configurator, containers, dmcc, http-client, io-streams, lens, monad-control, monad-logger, mtl, network, openssl-streams, random, safe-exceptions, stm, text, time, transformers, transformers-base, unix, unliftio, websockets, xml-conduit, xml-hamlet
Files
- CHANGELOG.md +5/−0
- LICENSE +32/−0
- README.md +106/−0
- dmcc-ws/Main.hs +242/−0
- dmcc-ws/example.cfg +39/−0
- dmcc.cabal +97/−0
- src/DMCC.hs +34/−0
- src/DMCC/Agent.hs +624/−0
- src/DMCC/Agent.hs-boot +29/−0
- src/DMCC/Prelude.hs +36/−0
- src/DMCC/Session.hs +533/−0
- src/DMCC/Session.hs-boot +9/−0
- src/DMCC/Types.hs +148/−0
- src/DMCC/Util.hs +11/−0
- src/DMCC/WebHook.hs +16/−0
- src/DMCC/XML/Raw.hs +82/−0
- src/DMCC/XML/Request.hs +425/−0
- src/DMCC/XML/Response.hs +320/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## [1.0.0.0] - 2018-05-10++[1.0.0.0]: https://github.com/f-me/dmcc/tree/1.0.0.0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2012, Max Taldykin, Timofey Cherganov+Copyright (c) 2014, 2015, 2016, 2017 Dmitry Dzhus+Copyright (c) 2018, Dmitry Dzhus, Viacheslav Lotsmanov++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 Tim nor the names of other+ 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+OWNER 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.
+ README.md view
@@ -0,0 +1,106 @@+# dmcc: AVAYA library for Haskell++[](https://travis-ci.org/f-me/dmcc)+[](https://hackage.haskell.org/package/dmcc)+[](http://packdeps.haskellers.com/feed?needle=dmcc)++This package contains a Haskell library which may be used to implement+computer telephony integration using [AVAYA DMCC XML API][dmcc-api]. A+simple server (dmcc-ws) built atop the library is also included. The+server allows clients use JSON-over-WebSockets to control AVAYA+agents, receive event notifications and agent state updates.++The package uses third-party call control functions of DMCC API.+There's no first-party call control support and no access to media+streams.++AVAYA DMCC XML API is largely based on [ECMA-354][] (CSTA Phase III)+standard, so in theory the package can be used with other compliant+telephony solutions.++## Features++- First-party interface for most of call control functions (making and+ answering calls, hold, conference call, transfer, barge in, state+ control).++- State change events (implemented in the library using polling to+ compensate for the lack of a native implementation in DMCC 6.x).++- Webhook support (the library can send HTTP requests in response to+ agent state change events).++## Site-specific notes++One basic TSAPI license is consumed for every agent controlled by+the library.++DMCC 6.x is supported. Consult your Avaya AES administration page to+check for software versions and available licenses.++## dmcc-ws server++The server exposes portions of Haskell library interface via+WebSockets using JSON messages for client-server exchange. Its purpose+is to provide a clean agent-centric interface to DMCC API suitable for+usage from client applications running in a browser.++The server is invoked as `dmcc-ws dmcc-ws.cfg`. See example+configuration file at `dmcc-ws/example.cfg`.++With `dmcc-ws` running, you may start controlling an agent with+extension `XXX`, connect to WebSocket URL `http://host:port/XXX`. The+server accepts client commands in JSON:++```json+{"action":"MakeCall", "number":"989150603267"}+```++Consult `DMCC.Action` documentation in Haddock docs for DMCC library+for supported commands.++The server reports telephony events along with updated agent snapshot:++```json+{+ "newSnapshot": {+ "state": ["Busy", ""],+ "calls": {+ "179": {+ "failed": false,+ "held": false,+ "ucid": "00001001791428242051",+ "interlocutors": [+ "989150603267:ADACs8300::0"+ ],+ "start": "2015-04-05T13:52:52.803Z",+ "direction": {+ "contents": [],+ "dir": "Out"+ },+ "answered": "2015-04-05T13:53:02.686Z"+ }+ }+ },+ "dmccEvent": {+ "callId": "179",+ "event": "EstablishedEvent"+ },+ "tag": "TelephonyEvent"+}+```++Client applications may use events to update their UI incrementally or+re-process the whole state every time an event arrives.++## macOS++On macOS with `openssl` installed via Homebrew, build with++```bash+stack build --extra-include-dirs=/usr/local/opt/openssl/include/ --extra-lib-dirs=/usr/local/opt/openssl/lib/+```++[dmcc-api]: https://www.devconnectprogram.com/site/global/products_resources/avaya_aura_application_enablement_services/interfaces/dmcc/overview/index.gsp++[ecma-354]: http://www.ecma-international.org/publications/standards/Ecma-354.htm
+ dmcc-ws/Main.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|++WebSockets interface for DMCC.++-}++module Main where++import DMCC.Prelude hiding (getArgs)++import Control.Monad.Logger.CallStack as CS++import Data.Aeson hiding (Error)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Configurator as Cfg+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version (showVersion)+import Data.String (fromString)++import Network.WebSockets++import System.Environment+import System.Exit+import System.Posix.Signals+import System.Random+import Text.Printf++import Paths_dmcc+import DMCC+++data Config = Config+ { listenPort :: Int+ , aesAddr :: String+ , aesPort :: Int+ , aesTLS :: Bool+ , caDir :: Maybe FilePath+ , apiUser :: Text+ , apiPass :: Text+ , whUrl :: Maybe String+ , refDelay :: Int+ , stateDelay :: Int+ , switchName :: SwitchName+ , logLibrary :: Bool+ , sessDur :: Int+ , connAtts :: Int+ , connDelay :: Int+ }+ deriving Show+++main :: IO ()+main = getArgs >>= \case+ [config] -> do+ this <- myThreadId+ let logger = runStdoutLoggingT++ -- Terminate on SIGTERM+ let termHandler = Catch $ do+ logger $ CS.logInfo "Termination signal received"+ throwTo this ExitSuccess++ _ <- installHandler sigTERM termHandler Nothing+ logger $ realMain logger config++ _ -> getProgName >>= \pn -> error $ "Usage: " <> pn <> " <path to config>"+++type AgentMap = TMVar (Map.Map AgentHandle Int)+++-- | Read config and actually start the server+realMain :: (MonadUnliftIO m, MonadLoggerIO m, MonadMask m, MonadBaseControl IO m)+ => (m () -> IO ())+ -> FilePath+ -> m ()+realMain logger config = do+ c <- liftIO $ Cfg.load [Cfg.Required config]+ cfg@Config{..} <- liftIO $ Config+ <$> Cfg.require c "listen-port"+ <*> Cfg.require c "aes-addr"+ <*> Cfg.require c "aes-port"+ <*> Cfg.lookupDefault True c "aes-use-tls"+ <*> Cfg.lookup c "aes-cacert-directory"+ <*> Cfg.require c "api-user"+ <*> Cfg.require c "api-pass"+ <*> Cfg.lookup c "web-hook-handler-url"+ <*> Cfg.lookupDefault 1 c "agent-release-delay"+ <*> Cfg.lookupDefault 1 c "state-polling-delay"+ <*> (SwitchName <$> Cfg.require c "switch-name")+ <*> Cfg.require c "log-library"+ <*> Cfg.require c "session-duration"+ <*> Cfg.require c "connection-retry-attempts"+ <*> Cfg.require c "connection-retry-delay"++ CS.logInfo $ "Running dmcc-" <> fromString (showVersion version)+ CS.logInfo $ "Starting session using " <> fromString (show cfg)++ let runSession = startSession+ (aesAddr, fromIntegral aesPort)+ (if aesTLS then TLS caDir else Plain)+ apiUser apiPass+ whUrl+ defaultSessionOptions { statePollingDelay = stateDelay+ , sessionDuration = sessDur+ , connectionRetryAttempts = connAtts+ , connectionRetryDelay = connDelay+ }++ releaseSession s = do+ CS.logInfo $ "Stopping " <> fromString (show s)+ stopSession s++ handleSession s = do+ CS.logInfo $ "Running server for " <> fromString (show s)+ (agentMap :: AgentMap) <- newTMVarIO Map.empty+ liftIO $ runServer "0.0.0.0" listenPort $ logger . avayaApplication cfg s agentMap++ bracket runSession releaseSession handleSession+++-- | Decrement reference counter for an agent. If no references left,+-- release control over agent. Return how many references are left.+releaseAgentRef :: (MonadUnliftIO m, MonadLoggerIO m, MonadMask m, MonadBaseControl IO m)+ => AgentHandle -> AgentMap -> m Int+releaseAgentRef ah refs = do+ r <- atomically $ takeTMVar refs+ flip onException (atomically $ putTMVar refs r) $+ case Map.lookup ah r of+ Just cnt -> do+ newR <-+ if cnt > 1+ then pure $ Map.insert ah (cnt - 1) r+ else do releaseAgent ah+ CS.logDebug $ "Agent " <> fromString (show ah) <> " is no longer controlled"+ pure $ Map.delete ah r++ atomically $ putTMVar refs newR+ pure $ cnt - 1++ Nothing -> error $ "Releasing unknown agent " <> show ah+++avayaApplication :: (MonadUnliftIO m, MonadLoggerIO m, MonadMask m, MonadBaseControl IO m)+ => Config+ -> Session+ -- ^ DMCC session.+ -> AgentMap+ -- ^ Reference-counting map of used agent ids.+ -> PendingConnection+ -> m ()+avayaApplication Config{..} as refs pending =+ case pathArg of+ [Nothing, Just ext] -> do+ -- A readable label for this connection for debugging purposes+ token <- liftIO $ randomRIO (1, 16 ^ (4 :: Int))++ let label = T.pack $ printf "%d/%04x" ext (token :: Int)+ -- Assume that all agents are on the same switch+ ext' = Extension $ T.pack $ show ext++ conn <- liftIO $ acceptRequest pending+ CS.logError $ "New websocket opened for " <> label++ -- Create a new agent reference, possibly establishing control over the agent+ r <- atomically $ takeTMVar refs++ let initialHandler = do+ CS.logDebug $ "Exception when plugging " <> label+ atomically $ putTMVar refs r+ CS.logDebug $ "Restored agent references map to " <> fromString (show r)++ (ah, evThread) <- flip onException initialHandler $ do+ cRsp <- controlAgent switchName ext' as+ ah <- case cRsp of+ Right ah' -> pure ah'+ Left err -> do+ liftIO $ sendTextData conn $ encode $ RequestError $ show err++ CS.logError $+ "Could not control agent for " <> label <> ": " <> fromString (show err)++ throwIO err++ -- Increment reference counter+ let oldCount = fromMaybe 0 $ Map.lookup ah r+ atomically $ putTMVar refs $ Map.insert ah (oldCount + 1) r+ CS.logDebug $ "Controlling agent " <> fromString (show ah) <> " from " <> label+ refReport ext' $ oldCount + 1++ -- Agent events loop+ evThread <-+ handleEvents ah $ \ev -> do+ CS.logInfo $ "Event for " <> label <> ": " <> fromString (show ev)+ liftIO $ sendTextData conn $ encode ev++ CS.logDebug $ fromString (show evThread) <> " handles events for " <> label+ pure (ah, evThread)++ let disconnectionHandler = do+ CS.logDebug $ "Websocket closed for " <> label+ killThread evThread+ threadDelay $ refDelay * 1000000+ -- Decrement reference counter when the connection dies or any+ -- other exception happens+ releaseAgentRef ah refs >>= refReport ext'++ handle (\(_ :: ConnectionException) -> disconnectionHandler) $ do+ s <- getAgentSnapshot ah+ liftIO $ sendTextData conn $ encode s++ -- Agent actions loop+ forever $ do+ msg <- liftIO $ receiveData conn++ case eitherDecode msg of+ Right act -> do+ CS.logDebug $ "Action from " <> label <> ": " <> fromString (show act)+ agentAction act ah++ Left e -> do+ CS.logDebug+ $ "Unrecognized message from " <> label <> ": "+ <> fromString (BL.unpack msg) <> " (" <> fromString e <> ")"++ liftIO $ sendTextData conn $ encode $ Map.fromList [("errorText" :: String, e)]++ _ -> liftIO $ rejectRequest pending "Malformed extension number"++ where+ pathArg = map (fmap fst . B.readInt) $ B.split '/' $ requestPath $ pendingRequest pending++ refReport ext cnt = CS.logDebug $+ fromString (show ext) <> " has " <> fromString (show cnt) <> " references"
+ dmcc-ws/example.cfg view
@@ -0,0 +1,39 @@+listen-port = 8333++aes-addr = "192.168.20.14"+aes-port = 4722+aes-use-tls = true++# Path to a directory which contains the PEM encoded CA root+# certificates used to verify server certificate. See+# http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html+# for details of the file naming scheme+#+# aes-cacert-directory = "/etc/ssl/csta-certs/"++api-user = "avaya"+api-pass = "avayapassword"++switch-name = "ADACs8300"++# Log low-level CSTA library requests/responses+log-library = false++# web-hook-handler-url = "http://localhost:8000/avaya/hook/"++# How quickly to release unused agents (in seconds). If no WebSocket+# clients use an agent for this interval, that agent is released (all+# monitoring stopped and events are no longer tracked for that agent).+agent-release-delay = 60++# How often to poll every agent for state changes (in seconds).+state-polling-delay = 1++# Session duration and session cleanup delay (in seconds). Keep alive+# messages are sent every half of session duration interval.+session-duration = 120++connection-retry-attempts = 24++# In seconds+connection-retry-delay = 5
+ dmcc.cabal view
@@ -0,0 +1,97 @@+cabal-version: >=1.10+name: dmcc+version: 1.0.0.0+license: BSD3+license-file: LICENSE+maintainer: dima@dzhus.org+author: Max Taldykin, Timofey Cherganov, Dmitry Dzhus, Viacheslav Lotsmanov+homepage: https://github.com/f-me/dmcc#readme+bug-reports: https://github.com/f-me/dmcc/issues+synopsis: AVAYA DMCC API bindings and WebSockets server for AVAYA+description:+ Partial implementation of CSTA Phase III XML Protocol (ECMA-323) with AVAYA (DMCC 6.3) extensions.+category: Network+build-type: Simple+extra-source-files:+ CHANGELOG.md+ dmcc-ws/example.cfg+ README.md++source-repository head+ type: git+ location: https://github.com/f-me/dmcc++library+ exposed-modules:+ DMCC+ DMCC.Agent+ DMCC.Prelude+ DMCC.Session+ DMCC.Types+ DMCC.Util+ DMCC.WebHook+ DMCC.XML.Raw+ DMCC.XML.Request+ DMCC.XML.Response+ hs-source-dirs: src+ other-modules:+ Paths_dmcc+ default-language: Haskell2010+ default-extensions: OverloadedStrings RecordWildCards+ NamedFieldPuns NoImplicitPrelude+ ghc-options: -Wall -Wcompat -Wno-missing-home-modules+ build-depends:+ HsOpenSSL <0.12,+ aeson <1.3,+ base <4.11,+ binary <0.9,+ bytestring <0.11,+ case-insensitive <1.3,+ classy-prelude <1.5,+ containers <0.6,+ http-client <0.6,+ io-streams <1.6,+ lens <4.17,+ monad-control <1.1,+ monad-logger <0.4,+ mtl <2.3,+ network <2.7,+ openssl-streams <1.3,+ safe-exceptions <0.2,+ stm <2.5,+ text <1.3,+ time <1.9,+ transformers <0.6,+ transformers-base <0.5,+ unliftio <0.3,+ xml-conduit <1.9,+ xml-hamlet <0.6++executable dmcc-ws+ main-is: Main.hs+ hs-source-dirs: dmcc-ws+ other-modules:+ Paths_dmcc+ default-language: Haskell2010+ default-extensions: OverloadedStrings RecordWildCards+ NamedFieldPuns NoImplicitPrelude+ ghc-options: -Wall -Wcompat -Wno-missing-home-modules -threaded+ build-depends:+ aeson <1.3,+ base <4.11,+ bytestring <0.11,+ classy-prelude <1.5,+ configurator <0.4,+ containers <0.6,+ dmcc -any,+ monad-control <1.1,+ monad-logger <0.4,+ random <1.2,+ safe-exceptions <0.2,+ stm <2.5,+ text <1.3,+ time <1.9,+ transformers-base <0.5,+ unix <2.8,+ unliftio <0.3,+ websockets <0.13
+ src/DMCC.hs view
@@ -0,0 +1,34 @@+{-|++DMCC XML API implementation for third party call control and+monitoring.++-}++module DMCC+ ( Session+ , ConnectionType (..)+ , startSession+ , stopSession+ , defaultSessionOptions++ , AgentHandle+ , controlAgent+ , releaseAgent++ , Action (..)+ , agentAction++ , AgentEvent (..)+ , AgentSnapshot (..)+ , handleEvents+ , getAgentSnapshot++ , module DMCC.Types+ )++where++import DMCC.Agent+import DMCC.Session+import DMCC.Types
+ src/DMCC/Agent.hs view
@@ -0,0 +1,624 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-|++Agents in a DMCC API session enable call control over devices.++-}++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+++-- | Actions performable by a controlled agent.+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)+ -- ^ Last recognized agent state along with reason code.+ }+ 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)+++-- | Events/errors are published to external clients of the+-- agents and may be used by agent subscribers to provide information+-- to user.+data AgentEvent = TelephonyEvent+ { dmccEvent :: Rs.Event+ , newSnapshot :: AgentSnapshot+ }+ -- ^ A telephony-related event, along with an updated+ -- snapshot.+ | StateChange{newSnapshot :: AgentSnapshot}+ -- ^ Arrives when an agent state change has been+ -- observed.+ | TelephonyEventError{errorText :: String}+ -- ^ An error caused by a telephony-related event.+ | RequestError{errorText :: String}+ -- ^ An error caused by a request from this agent.+ deriving Show+++$(deriveJSON defaultOptions ''AgentEvent)+++-- | Web hook event.+data WHEvent = WHEvent+ { agentId :: AgentId+ , event :: AgentEvent+ }+ deriving Show+++$(deriveJSON defaultOptions ''WHEvent)+++-- | An agent controlled by a DMCC API session.+data Agent = Agent+ { deviceId :: DeviceId+ , monitorId :: Text+ , actionChan :: TChan Action+ -- ^ Actions performed by the agent.+ , actionThread :: ThreadId+ , rspChan :: TChan Rs.Response+ -- ^ Input chan for XML responses for this agent (including+ -- events).+ , rspThread :: ThreadId+ -- ^ Response reader.+ , stateThread :: ThreadId+ -- ^ Agent state poller.+ , 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+++-- | Exceptions thrown by agent-related routines and threads.+data AgentError+ = DeviceError String+ | MonitoringError String+ | StatePollingError String+ | UnknownAgent AgentId+ deriving (Data, Typeable, Show)+++instance (Exception AgentError)+++-- | Command an agent to do something.+--+-- Due to lack of global locking of the agents map an agent may be+-- gone (released) by the time an action arrives to its actionChan.+-- This is by design to avoid congestion during action processing.+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)+++-- | Enable an active agent to be monitored and controlled through+-- DMCC API. If the agent has already been registered, return the old+-- entry (it's safe to call this function with the same arguments+-- multiple times).+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)+ -- Check if agent already exists+ 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+ -- Prevent parallel operation on the same agent+ else placeAgentLock ah >> pure Nothing+ case prev of+ Just a -> pure $ Right $ AgentHandle (a, as)+ Nothing -> try $ flip onException (releaseAgentLock ah) $+ do+ -- Get Avaya info for this agent (note that requests are not+ -- attached to the agent (Nothing) as it has not been inserted+ -- in the agent map of the session yet).+ 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"++ -- Setup action and event processing for this agent+ 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++ -- As of DMCC 6.2.x, agent state change events are not+ -- reported by DMCC (see+ -- https://www.devconnectprogram.com/forums/posts/list/18511.page).+ -- We use polling to inform our API clients about update in+ -- the agent state.++ -- Find out initial agent state+ 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"+ -- State polling thread+ 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 ()+ -- Ignore state errors+ _ -> 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+++-- | Translate agent actions into actual DMCC API requests.+--+-- TODO Allow agents to control only own calls.+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+ -- We ignore bad requests here. All CSTA errors will be reported+ -- to the agent.+ MakeCall toNumber -> do+ rspDest <-+ sendRequestSync (dmccHandle as) (Just aid)+ Rq.GetThirdPartyDeviceId+ -- Assume destination switch is the same as agent's+ { 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+ -- Find the call we've stepped in among other agents' calls+ -- and copy it to us+ 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+ -- Synchronous to avoid missed digits if actions queue up+ 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+++-- | Process DMCC API events/errors for this agent to change its snapshot+-- and broadcast events further.+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+ -- Report all errors to the agent+ Rs.CSTAErrorCodeResponse err ->+ atomically $ writeTChan eventChan $ RequestError $ unpack err++ -- New outgoing call+ --+ -- MakeCallResponse handler should have already added the call+ -- information to agent state. If this is not the case (which+ -- occurs when multiple DMCC library sessions interact with the+ -- same AVAYA instance), we add the call after finding out its+ -- UCID.+ 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 ()+++ -- All other telephony events+ Rs.EventResponse _ ev -> do+ (updSnapshot, report) <- atomically $ do+ -- Return True if the event must be reported to agent event chan+ report <- case ev of+ Rs.OriginatedEvent{..} ->+ -- Should have already been handled in a branch above+ pure True+ -- New call+ Rs.DeliveredEvent{..} -> do+ s <- readTVar snapshot+ if Map.member callId $ _calls s+ then pure False+ else -- DeliveredEvent arrives after OriginatedEvent for+ -- outgoing calls too, but we keep the original call+ -- information.+ 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+ -- ConnectionCleared event arrives when line is put on HOLD too.+ -- A real call-ending ConnectionCleared is distinguished by its+ -- releasingDevice value.+ 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+ -- Conferencing call A to call B yields ConferencedEvent with+ -- primaryCall=B and secondaryCall=A, while call A dies.+ 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+ -- ConferencedEvent may also be produced after a new+ -- established call but not caused by an actual conference+ -- user request (recorder single-stepping in).+ _ -> 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)+ -- Call webhook if necessary+ case (webHook as, report) of+ (Just connData, True) -> sendWH connData aid $ TelephonyEvent ev updSnapshot+ _ -> pure ()+ -- All other responses cannot arrive to an agent+ _ -> pure ()++ where+ -- | Atomically modify one of the calls.+ callOperation :: CallId+ -- ^ CallId to find in calls map+ -> (Call -> Map.Map CallId Call -> Map.Map CallId Call)+ -- ^ How to modify calls map if the call has been found+ -> String+ -- ^ Error message if no such call found+ -> 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+++-- | Send agent event data to a web hook endpoint, ignoring possible+-- exceptions.+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+++-- | Forget about an agent, releasing his device and monitors.+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 ()+++-- | Attach an event handler to an agent. Exceptions are not handled.+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
+ src/DMCC/Agent.hs-boot view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}++module DMCC.Agent++where++import DMCC.Prelude++import Data.Text (Text)++import DMCC.Types+import qualified DMCC.XML.Response as Rs+import {-# SOURCE #-} DMCC.Session+++data Agent+++newtype AgentHandle = AgentHandle (AgentId, Session)+++monitorId :: Agent -> Text+++rspChan :: Agent -> TChan Rs.Response+++releaseAgent :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => AgentHandle -> m ()
+ src/DMCC/Prelude.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE ConstraintKinds #-}++module DMCC.Prelude+ ( module ClassyPrelude+ , module UnliftIO.IO+ , module UnliftIO.STM+ , module UnliftIO.Concurrent+ , module Control.Monad.Base+ , module Control.Monad.Trans.Control+ , module Control.Exception.Safe+ , module Control.Monad.Logger+ )++where++import ClassyPrelude hiding ( atomically+ , newBroadcastTChanIO+ , newEmptyTMVarIO+ , newTBQueueIO+ , newTChanIO+ , newTMVarIO+ , newTQueueIO+ , newTVarIO+ , readTVarIO+ , mkWeakTVar+ , mkWeakTMVar+ , registerDelay+ )++import UnliftIO.IO+import UnliftIO.STM+import UnliftIO.Concurrent+import Control.Monad.Base (MonadBase)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Exception.Safe (MonadThrow, MonadCatch, MonadMask)+import Control.Monad.Logger
+ src/DMCC/Session.hs view
@@ -0,0 +1,533 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{-|+DMCC session handling.+-}++module DMCC.Session+ ( Session (..)+ , ConnectionType (..)+ , startSession+ , stopSession+ , defaultSessionOptions++ , DMCCError (..)++ , DMCCHandle (..)+ , sendRequestSync+ , sendRequestAsync+ )++where++import DMCC.Prelude++import Control.Arrow ()+import Control.Concurrent.STM.TMVar (tryPutTMVar)++import Data.ByteString (ByteString)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.IntMap.Strict as IntMap+import Data.Text as T (Text, empty)+import Data.Typeable ()++import System.IO.Streams ( InputStream+ , OutputStream+ , ReadTooShortException+ , write+ )+import System.IO.Streams.Handle+import qualified System.IO.Streams.SSL as SSLStreams++import Network+import qualified Network.HTTP.Client as HTTP+import Network.Socket hiding (connect)+import OpenSSL+import qualified OpenSSL.Session as SSL++import DMCC.Types+import DMCC.XML.Request (Request)+import qualified DMCC.XML.Request as Rq+import DMCC.XML.Response (Response)+import qualified DMCC.XML.Response as Rs+import qualified DMCC.XML.Raw as Raw++import {-# SOURCE #-} DMCC.Agent+++data ConnectionType = Plain+ | TLS { caDir :: Maybe FilePath }+++-- | Third element is a connection close action.+type ConnectionData = (InputStream ByteString, OutputStream ByteString, IO ())+++-- | Low-level DMCC API plumbing.+data DMCCHandle = DMCCHandle+ { connection :: TMVar ConnectionData+ -- ^ AVAYA server socket streams and connection cleanup action.+ , dmccSession :: TMVar (Text, Int)+ -- ^ DMCC session ID and duration.+ , reconnect :: forall m+ . (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => m ()+ -- ^ Reconnect to AVAYA server, changing socket streams, cleanup+ -- action and session.+ , pingThread :: ThreadId+ , readThread :: ThreadId+ -- ^ DMCC response reader thread.+ , procThread :: ThreadId+ -- ^ Response handler/synchronous requests worker thread.+ , invokeId :: TVar Int+ -- ^ Request/response counter.+ , syncResponses :: TVar (IntMap.IntMap (TMVar (Maybe Response)))+ , agentRequests :: TVar (IntMap.IntMap AgentId)+ -- ^ Keeps track of which request has has been issued by what agent+ -- (if there's one) until its response arrives.+ , sessionOptions :: SessionOptions+ }+++-- | Library API session.+data Session = Session+ { protocolVersion :: Text+ , dmccHandle :: DMCCHandle+ , webHook :: Maybe (HTTP.Request, HTTP.Manager)+ -- ^ Web hook handler URL and manager.+ , agents :: TVar (Map.Map AgentId Agent)+ , agentLocks :: TVar (Set.Set AgentId)+ }+++instance Show Session where+ show as = "Session{protocolVersion=" <> unpack (protocolVersion as) <> "}"+++data LoopEvent+ = DMCCRsp Response+ | Timeout+ | ReadError+ deriving Show+++data DMCCError = ApplicationSessionFailed+ deriving (Show, Typeable)+++instance Exception DMCCError+++defaultSessionOptions :: SessionOptions+defaultSessionOptions = SessionOptions 1 120 24 5+++startSession :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => (String, PortNumber)+ -- ^ Host and port of AES server.+ -> ConnectionType+ -- ^ Use TLS.+ -> Text+ -- ^ DMCC API user.+ -> Text+ -- ^ DMCC API password.+ -> Maybe String+ -- ^ Web hook URL.+ -> SessionOptions+ -> m Session+startSession (host, port) ct user pass whUrl sopts = do+ syncResponses <- newTVarIO IntMap.empty+ agentRequests <- newTVarIO IntMap.empty+ invoke <- newTVarIO 0++ -- When this is empty, I/O streams to the server are not ready.+ conn <- newEmptyTMVarIO+ -- When this is empty, DMCC session is not ready or is being+ -- recovered.+ sess <- newEmptyTMVarIO++ let+ -- Connect to the server, produce I/O streams and a cleanup action+ connect :: (MonadUnliftIO m, MonadBase IO m, MonadLoggerIO m, MonadCatch m) => m ConnectionData+ connect = connect1 (connectionRetryAttempts sopts)+ where+ connectExHandler+ :: (Exception e, Show e, MonadUnliftIO m, MonadLoggerIO m, MonadBase IO m, MonadCatch m)+ => Int -> e -> m ConnectionData+ connectExHandler attempts e = do+ logErrorN $ "Connection failed: " <> tshow e+ if attempts > 0+ then threadDelay (connectionRetryDelay sopts * 1000000) >> connect1 (attempts - 1)+ else throwIO e+ connect1 attempts =+ handleNetwork (connectExHandler attempts) $+ liftIO $ case ct of+ Plain -> do+ h <- connectTo host (PortNumber $ fromIntegral port)+ hSetBuffering h NoBuffering+ is <- handleToInputStream h+ os <- handleToOutputStream h+ let cl = hClose h+ pure (is, os, cl)+ TLS caDir -> withOpenSSL $ do+ sslCtx <- SSL.context+ SSL.contextSetDefaultCiphers sslCtx+ SSL.contextSetVerificationMode sslCtx $+ SSL.VerifyPeer True True Nothing+ maybe (pure ()) (SSL.contextSetCADirectory sslCtx) caDir+ (is, os, ssl) <- SSLStreams.connect sslCtx host port+ let cl = do+ SSL.shutdown ssl SSL.Unidirectional+ maybe (pure ()) close $ SSL.sslSocket ssl+ pure (is, os, cl)++ -- Start new DMCC session+ startDMCCSession :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => Maybe Text+ -- ^ Previous session ID (we attempt to recover+ -- when this is given).+ -> m ((Text, Int), Text)+ startDMCCSession old = do+ let+ sendReq =+ sendRequestSyncRaw+ conn+ reconnect+ invoke+ syncResponses+ Nothing+ startReq sid =+ sendReq+ Rq.StartApplicationSession+ { applicationId = ""+ , requestedProtocolVersion = Rq.DMCC_6_2+ , userName = user+ , password = pass+ , sessionCleanupDelay = sessionDuration sopts+ , sessionID = fromMaybe T.empty sid+ , requestedSessionDuration = sessionDuration sopts+ }+ -- Start a session monitor to enable TransferMonitorObjects+ -- feature+ sessionMonitorReq proto =+ sendReq+ Rq.MonitorStart+ { acceptedProtocol = proto+ , monitorRq = Rq.Session+ }+ startRsp <- startReq old+ case (startRsp, old) of+ (Just Rs.StartApplicationSessionPosResponse{..}, _) -> do+ _ <- sessionMonitorReq actualProtocolVersion+ pure ((sessionID, actualSessionDuration), actualProtocolVersion)+ (Just Rs.StartApplicationSessionNegResponse, Just oldID) -> do+ -- The old session has expired, start from scratch+ startRsp' <- startReq Nothing+ case startRsp' of+ Just Rs.StartApplicationSessionPosResponse{..} -> do+ _ <- sessionMonitorReq actualProtocolVersion+ -- Transfer MonitorObjects from old session+ sendRequestAsyncRaw+ conn+ reconnect+ invoke+ Nothing+ Rq.TransferMonitorObjects+ { fromSessionID = oldID+ , toSessionID = sessionID+ , acceptedProtocol = actualProtocolVersion+ }+ pure ((sessionID, actualSessionDuration), actualProtocolVersion)+ _ -> throwIO ApplicationSessionFailed+ _ -> throwIO ApplicationSessionFailed++ -- Restart I/O and DMCC session. This routine returns when new I/O+ -- streams become available (starting DMCC session requires+ -- response reader thread to be functional).+ reconnect :: (MonadUnliftIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadCatch m) => m ()+ reconnect = do+ logWarnN "Attempting reconnection"+ -- Only one reconnection at a time+ (oldId, cl) <- atomically $ do+ (oldId, _) <- takeTMVar sess+ (_, _, cl) <- takeTMVar conn+ pure (oldId, cl)+ -- Fail all pending synchronous requests+ atomically $ do+ srs <- readTVar syncResponses+ mapM_ (`putTMVar` Nothing) $ IntMap.elems srs+ writeTVar syncResponses IntMap.empty+ handle+ (\(e :: IOException) -> logErrorN $ "Failed to close old connection: " <> tshow e) $+ liftIO cl+ -- We do not change the protocol version during session recovery+ connect >>= atomically . putTMVar conn+ logWarnN "Connection re-established"+ let+ shdl (Right ()) = pure ()+ shdl (Left e) = throwIO e+ -- Fork new thread for DMCC session initialization. This is+ -- because 'reconnect' needs to return for response reader+ -- thread to start working again (which is required for DMCC+ -- session start).+ void $ flip forkFinally shdl $ do+ (newSession, _) <- startDMCCSession (Just oldId)+ atomically $ putTMVar sess newSession++ -- Read DMCC responses from socket+ msgChan <- newTChanIO+ let readExHandler e = do+ logErrorN $ "Read error: " <> tshow e+ reconnect+ readThread <-+ forkIO $ forever $ do+ (istream, _, _) <- atomically $ readTMVar conn+ handleNetwork readExHandler $+ Raw.readResponse istream >>=+ atomically . writeTChan msgChan . first DMCCRsp++ agents <- newTVarIO Map.empty++ -- Process parsed messages+ procThread <- forkIO $ forever $ do+ (msg, invokeId) <- atomically $ readTChan msgChan+ -- TODO Check agent locks?+ ags <- readTVarIO agents+ case msg of+ DMCCRsp rsp -> do+ -- Return response if the request was synchronous+ sync' <- atomically $ do+ srs <- readTVar syncResponses+ modifyTVar' syncResponses (IntMap.delete invokeId)+ pure $ IntMap.lookup invokeId srs+ case sync' of+ Just sync -> void $ atomically $ tryPutTMVar sync $ Just rsp+ Nothing -> pure ()+ -- Redirect events and request errors to matching agent+ ag' <- case rsp of+ Rs.EventResponse monId _ ->+ pure $ find (\a -> monId == monitorId a) $ Map.elems ags+ Rs.CSTAErrorCodeResponse _ -> do+ aid <- atomically $ do+ ars <- readTVar agentRequests+ modifyTVar' agentRequests (IntMap.delete invokeId)+ pure $ IntMap.lookup invokeId ars+ pure $ (`Map.lookup` ags) =<< aid+ _ -> pure Nothing+ case ag' of+ Just ag -> atomically $ writeTChan (rspChan ag) rsp+ -- Error/event received for an unknown agent?+ Nothing -> pure ()+ _ -> pure ()++ -- Keep the session alive+ pingThread <- forkIO $ forever $ do+ -- Do not send a keep-alive message if the session is not ready+ (sid, duration) <- atomically $ readTMVar sess+ sendRequestAsyncRaw conn reconnect invoke Nothing+ Rq.ResetApplicationSessionTimer+ { sessionId = sid+ , requestedSessionDuration = duration+ }+ threadDelay $ duration * 500 * 1000++ let h = DMCCHandle+ conn+ sess+ reconnect+ pingThread+ readThread+ procThread+ invoke+ syncResponses+ agentRequests+ sopts++ -- Start the session+ connect >>= atomically . putTMVar conn+ (newSession, actualProtocolVersion) <- startDMCCSession Nothing+ atomically $ putTMVar sess newSession++ wh <- case whUrl of+ Just url -> do+ mgr <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings+ req <- HTTP.parseUrlThrow url+ pure $ Just (req, mgr)+ Nothing -> pure Nothing++ agLocks <- newTVarIO Set.empty++ pure $+ Session+ actualProtocolVersion+ h+ wh+ agents+ agLocks+++-- | TODO Agent releasing notice+stopSession :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => Session -> m ()+stopSession as@Session{..} = do+ -- Release all agents+ ags <- readTVarIO agents+ (s, _) <- atomically $ readTMVar $ dmccSession dmccHandle+ forM_ (keys ags) $ releaseAgent . \aid -> AgentHandle (aid, as)++ sendRequestAsync dmccHandle Nothing Rq.StopApplicationSession{sessionID = s}++ -- TOOD Use async/throwTo instead+ killThread $ pingThread dmccHandle+ killThread $ procThread dmccHandle+ killThread $ readThread dmccHandle+ (_, ostream, cleanup) <- atomically $ readTMVar $ connection dmccHandle+ liftIO $ do+ write Nothing ostream+ cleanup+++-- | Send a request and block until the response arrives or a write+-- exception occurs. No request is sent until a connection and an+-- application session become available. Write exceptions cause a+-- reconnection and a session restart, Nothing is returned in this+-- case.+--+-- This must not be used to for session setup as this requires an+-- active DMCC application session!+--+-- Write errors are made explicit here because 'sendRequestSync' is+-- called from multiple locations, making it tedious to install the+-- reconnection handler everywhere.+sendRequestSync :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => DMCCHandle+ -> Maybe AgentId+ -- ^ Push erroneous responses to this agent's event+ -- processor.+ --+ -- TODO Disallow unknown agents on type level (use+ -- AgentHandle).+ -> Request+ -> m (Maybe Response)+sendRequestSync DMCCHandle{..} aid rq = do+ void $ atomically $ readTMVar dmccSession+ sendRequestSyncRaw+ connection+ reconnect+ invokeId+ syncResponses+ ((agentRequests, ) <$> aid)+ rq+++sendRequestSyncRaw :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => TMVar ConnectionData+ -- ^ Block until this connection becomes available.+ -> m ()+ -- ^ Reconnection action.+ -> TVar Int+ -> TVar (IntMap.IntMap (TMVar (Maybe Response)))+ -- ^ Synchronous response storage.+ -> Maybe (TVar (IntMap.IntMap AgentId), AgentId)+ -- ^ Agent requests map and target agent id. When+ -- provided, CSTAErrorCode response will be+ -- directed to that agent's event processor.+ -> Request+ -> m (Maybe Response)+sendRequestSyncRaw connection re invoke srs ar !rq = do+ (ix, var, c@(_, ostream, _)) <- atomically $ do+ modifyTVar' invoke $ (`mod` 9999) . (+1)+ ix <- readTVar invoke+ var <- newEmptyTMVar+ modifyTVar' srs (IntMap.insert ix var)+ case ar of+ Just (ars, a) -> modifyTVar' ars (IntMap.insert ix a)+ Nothing -> pure ()+ c <- takeTMVar connection+ pure (ix, var, c)+ let+ srHandler e = do+ logErrorN $ "Write error: " <> tshow e+ atomically $ do+ putTMVar connection c+ putTMVar var Nothing+ modifyTVar' srs $ IntMap.delete ix+ case ar of+ Just (ars, _) -> modifyTVar' ars (IntMap.delete ix)+ Nothing -> pure ()+ re+ handleNetwork srHandler $ Raw.sendRequest ostream ix rq+ -- Release the connection at once and wait for response in a+ -- separate transaction.+ atomically $ putTMVar connection c+ atomically $ takeTMVar var+++-- | Like 'sendRequestAsync', but do not wait for a result.+sendRequestAsync :: (MonadUnliftIO m, MonadLoggerIO m, MonadBaseControl IO m, MonadCatch m)+ => DMCCHandle+ -> Maybe AgentId+ -- ^ Push erroneous responses to this agent's event+ -- processor.+ -> Request+ -> m ()+sendRequestAsync DMCCHandle{..} aid rq = do+ _ <- atomically $ readTMVar dmccSession+ sendRequestAsyncRaw+ connection+ reconnect+ invokeId+ ((agentRequests, ) <$> aid)+ rq+++sendRequestAsyncRaw :: (MonadUnliftIO m, MonadLoggerIO m, MonadCatch m)+ => TMVar ConnectionData+ -- ^ Block until this connection becomes available.+ -> m ()+ -- ^ Reconnection action.+ -> TVar Int+ -> Maybe (TVar (IntMap.IntMap AgentId), AgentId)+ -> Request+ -> m ()+sendRequestAsyncRaw connection re invoke ar !rq = do+ (ix, c@(_, ostream, _)) <- atomically $ do+ modifyTVar' invoke $ (`mod` 9999) . (+1)+ ix <- readTVar invoke+ case ar of+ Just (ars, a) -> modifyTVar' ars (IntMap.insert ix a)+ Nothing -> pure ()+ c <- takeTMVar connection+ pure (ix, c)+ let+ srHandler e = do+ logErrorN $ "Write error: " <> tshow e+ atomically $ do+ putTMVar connection c+ case ar of+ Just (ars, _) -> modifyTVar' ars (IntMap.delete ix)+ Nothing -> pure ()+ re+ handleNetwork srHandler $ Raw.sendRequest ostream ix rq+ atomically $ putTMVar connection c+++-- | Handle network-related errors we know of.+handleNetwork :: forall a m. (MonadUnliftIO m, MonadLoggerIO m, MonadCatch m)+ => (forall e. (Exception e, Show e) => (e -> m a))+ -- ^ Exception handler.+ -> m a+ -> m a+handleNetwork handler action = action `catches`+ [ Handler (\(e :: ReadTooShortException) -> handler e)+ , Handler (\(e :: IOException) -> handler e)+ , Handler (\(e :: SSL.ConnectionAbruptlyTerminated) -> handler e)+ , Handler (\(e :: SSL.ProtocolError) -> handler e)+ ]
+ src/DMCC/Session.hs-boot view
@@ -0,0 +1,9 @@+module DMCC.Session++where++import DMCC.Prelude++data Session++instance Show Session
+ src/DMCC/Types.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++{-| Shared type declarations. -}++module DMCC.Types++where++import DMCC.Prelude++import Data.Aeson as A+import Data.Aeson.TH+import Data.ByteString (ByteString)+import Data.CaseInsensitive+import Data.Data+import Data.Text as T+++-- | Device ID used in DMCC requests.+--+-- This is based on text as stated in DMCC specification.+newtype DeviceId =+ DeviceId (CI Text)+ deriving (Eq, Ord, Show)+++instance FromJSON DeviceId where+ parseJSON v = DeviceId . mk <$> parseJSON v+++instance ToJSON DeviceId where+ toJSON (DeviceId t) = toJSON $ original t+++newtype CallId =+ CallId Text+ deriving (Eq, Ord, Show, FromJSON, ToJSON)+++-- | Globally unique call ID.+newtype UCID =+ UCID Text+ deriving (Eq, Ord, Show, FromJSON, ToJSON)+++newtype Extension =+ Extension Text+ deriving (Eq, Ord, Show,+ Data, Typeable, ToJSON)+++instance FromJSON Extension where+ parseJSON (A.String s)+ | T.length s > 30 = fail "Maximum extension length is 30 digits"+ | (\c -> c `elem` (['0'..'9'] <> ['*', '#'])) `T.all` s = pure $ Extension s+ | otherwise = fail "Extension must contain the digits 0-9, * or #"+ parseJSON _ = fail "Could not parse extension"+++newtype SwitchName =+ SwitchName Text+ deriving (Eq, Ord, Show, Data, Typeable, FromJSON, ToJSON)+++newtype AgentId =+ AgentId (SwitchName, Extension)+ deriving (Data, Typeable, Eq, Ord, Show, FromJSON, ToJSON)+++data CallDirection = In { vdn :: DeviceId }+ | Out+ deriving (Eq, Show)+++$(deriveJSON+ defaultOptions{sumEncoding = defaultTaggedObject{tagFieldName="dir"}}+ ''CallDirection)+++data Call = Call+ { direction :: CallDirection+ , ucid :: UCID+ , start :: UTCTime+ -- ^ When did call came into existence?+ , interlocutors :: [DeviceId]+ , answered :: Maybe UTCTime+ -- ^ When did another party answer this call?+ , held :: Bool+ , failed :: Bool+ }+ deriving Show+++$(deriveJSON defaultOptions ''Call)+++data SettableAgentState = Ready+ | AfterCall+ | NotReady+ | Logout+ deriving (Eq, Show)+++$(deriveJSON defaultOptions ''SettableAgentState)+++data AgentState = Busy+ | Settable SettableAgentState+ deriving (Eq, Show)+++instance ToJSON AgentState where+ toJSON Busy = String "Busy"+ toJSON (Settable s) = toJSON s+++instance FromJSON AgentState where+ parseJSON (String "Busy") = pure Busy+ parseJSON s@(String _) = Settable <$> parseJSON s+ parseJSON _ = fail "Could not parse AgentState"+++data ParticipationType = Active+ | Silent+ deriving (Eq, Show)+++$(deriveJSON defaultOptions ''ParticipationType)+++-- TODO This should be removed+newtype LoggingOptions = LoggingOptions+ { syslogIdent :: ByteString+ }+++data SessionOptions = SessionOptions+ { statePollingDelay :: Int+ -- ^ How often to poll every agent for state changes (in seconds).+ , sessionDuration :: Int+ -- ^ Serves both as session duration and session cleanup delay (in+ -- seconds).+ , connectionRetryAttempts :: Int+ , connectionRetryDelay :: Int+ -- ^ In seconds.+ }
+ src/DMCC/Util.hs view
@@ -0,0 +1,11 @@+module DMCC.Util where++import DMCC.Prelude++import Data.Text as T+import Control.Monad.Logger.CallStack as CS+import DMCC.Types++maybeSyslog :: MonadLogger m => Maybe LoggingOptions -> String -> m ()+maybeSyslog Nothing _ = pure ()+maybeSyslog (Just LoggingOptions{..}) msg = CS.logInfo $ T.pack msg
+ src/DMCC/WebHook.hs view
@@ -0,0 +1,16 @@+{-|++Types and instances for implementing webhook interface for DMCC.++-}++module DMCC.WebHook+ ( WHEvent (..)+ , AgentEvent (..)+ , Event (..)+ )++where++import DMCC.Agent+import DMCC.XML.Response
+ src/DMCC/XML/Raw.hs view
@@ -0,0 +1,82 @@+{-|++DMCC request/response packet processing.+++DMCC header format:++@+| 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | ... |+| Version | Length | InvokeID | XML Message Body |+@++-}++module DMCC.XML.Raw where++import DMCC.Prelude++import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8++import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams++import Text.Printf++import DMCC.XML.Request+import DMCC.XML.Response+++-- FIXME: error+sendRequest :: MonadLoggerIO m+ => OutputStream S.ByteString+ -> Int+ -> Request+ -> m ()+sendRequest h ix rq = do+ logDebugN+ $ "Sending request (invokeId=" <> tshow ix <> ") "+ <> tshow (L8.unpack rawRequest)++ liftIO $ flip Streams.writeLazyByteString h $ runPut $ do+ putWord16be 0+ putWord16be . fromIntegral $ 8 + L.length rawRequest+ let invokeId = S.pack . take 4 $ printf "%04d" ix+ putByteString invokeId+ putLazyByteString rawRequest++ where rawRequest = toXml rq+++-- | Read a CSTA message from an input stream. Throws+-- 'ReadTooShortException'.+readResponse :: MonadLoggerIO m+ => InputStream S.ByteString+ -> m (Response, Int)+readResponse h = do+ -- xml-conduit parser requires a lazy ByteString+ let readLazy i = do+ v <- Streams.readExactly i h+ pure $ L.fromChunks [v]++ (len, invokeId) <- liftIO $ runGet readHeader <$> readLazy 8+ resp <- liftIO $ readLazy $ len - 8++ logDebugN+ $ "Received response (invokeId=" <> tshow invokeId <> ") "+ <> tshow (L8.unpack resp)++ pure (fromXml resp, invokeId)++ where+ readHeader = do+ skip 2 -- version+ len <- fromIntegral <$> getWord16be+ ix <- getByteString 4+ case S.readInt ix of+ Just (invokeId, "") -> pure (len, invokeId)+ _ -> fail $ "Invalid InvokeID: " <> show ix
+ src/DMCC/XML/Request.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE QuasiQuotes #-}++{-| Low-level XML API requests. -}++module DMCC.XML.Request++where++import DMCC.Prelude++import qualified Data.ByteString.Lazy as L+import Data.CaseInsensitive+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T++import Text.Hamlet.XML+import Text.XML++import DMCC.Types+++data Request+ = StartApplicationSession+ { applicationId :: Text+ , requestedProtocolVersion :: ProtocolVersion+ , userName :: Text+ , password :: Text+ , sessionCleanupDelay :: Int+ , sessionID :: Text+ , requestedSessionDuration :: Int+ }+ | StopApplicationSession+ { sessionID :: Text+ }+ | ResetApplicationSessionTimer+ { sessionId :: Text+ , requestedSessionDuration :: Int+ }+ | GetDeviceId+ { switchName :: SwitchName+ , extension :: Extension+ }+ | GetThirdPartyDeviceId+ { switchName :: SwitchName+ , extension :: Extension+ }+ | MakeCall+ { callingDevice :: DeviceId+ , calledDirectoryNumber :: DeviceId+ , acceptedProtocol :: Text+ }+ | AnswerCall+ { deviceId :: DeviceId+ , callId :: CallId+ , acceptedProtocol :: Text+ }+ | HoldCall+ { deviceId :: DeviceId+ , callId :: CallId+ , acceptedProtocol :: Text+ }+ | RetrieveCall+ { deviceId :: DeviceId+ , callId :: CallId+ , acceptedProtocol :: Text+ }+ | GenerateDigits+ { charactersToSend :: Text+ , deviceId :: DeviceId+ , callId :: CallId+ , acceptedProtocol :: Text+ }+ | ConferenceCall+ { deviceId :: DeviceId+ , activeCall :: CallId+ , heldCall :: CallId+ , acceptedProtocol :: Text+ }+ | SingleStepConferenceCall+ { deviceId :: DeviceId+ , activeCall :: CallId+ , acceptedProtocol :: Text+ , participationType :: ParticipationType+ }+ | TransferCall+ { deviceId :: DeviceId+ , activeCall :: CallId+ , heldCall :: CallId+ , acceptedProtocol :: Text+ }+ | ClearConnection+ { deviceId :: DeviceId+ , callId :: CallId+ , acceptedProtocol :: Text+ }+ | ReleaseDeviceId+ { device :: DeviceId+ }+ | MonitorStart+ { acceptedProtocol :: Text+ , monitorRq :: MonitorRequest+ }+ | MonitorStop+ { acceptedProtocol :: Text+ , monitorCrossRefID :: Text+ }+ | TransferMonitorObjects+ { fromSessionID :: Text+ , toSessionID :: Text+ , acceptedProtocol :: Text+ }+ | GetAgentState+ { device :: DeviceId+ , acceptedProtocol :: Text+ }+ | SetAgentState+ { device :: DeviceId+ , requestedAgentState :: SettableAgentState+ , acceptedProtocol :: Text+ }+ | GetCallLinkageData+ { deviceId :: DeviceId+ , callId :: CallId+ , acceptedProtocol :: Text+ }+ deriving Show+++data MonitorRequest = Device {deviceObject :: DeviceId}+ | Session+ deriving Show+++data ProtocolVersion = DMCC_6_1 | DMCC_6_2 | DMCC_6_3+ deriving Show+++getProtocolString :: ProtocolVersion -> Text+getProtocolString ver+ = case ver of+ DMCC_6_1 -> "http://www.ecma-international.org/standards/ecma-323/csta/ed3/priv5"+ DMCC_6_2 -> "http://www.ecma-international.org/standards/ecma-323/csta/ed3/priv6"+ DMCC_6_3 -> "http://www.ecma-international.org/standards/ecma-323/csta/ed3/priv7"+++nsAppSession :: Text+nsAppSession = "http://www.ecma-international.org/standards/ecma-354/appl_session"+++nsXSI :: Text+nsXSI = "http://www.w3.org/2001/XMLSchema-instance"+++nsACX :: Text+nsACX = "http://www.avaya.com/csta"+++doc :: Name -> Text -> [Node] -> Document+doc name xmlns nodes = Document+ (Prologue [] Nothing [])+ (Element+ name+ (Map.fromList+ [ ("xmlns", xmlns)+ , ("xmlns:xsi", nsXSI)+ , ("xmlns:acx", nsACX)+ ])+ nodes)+ []+++class ToText a where+ toText :: a -> Text+++instance ToText (CI Text) where+ toText t = toText $ original t+++instance ToText Text where+ toText t = t+++instance ToText Extension where+ toText (Extension e) = e+++instance ToText SettableAgentState where+ toText Ready = "ready"+ toText AfterCall = "workingAfterCall"+ toText NotReady = "notReady"+ toText Logout = "loggedOff"+++deriving instance ToText DeviceId+++deriving instance ToText SwitchName+++deriving instance ToText CallId+++instance ToText ParticipationType where+ toText Active = "active"+ toText Silent = "silent"+++toXml :: Request -> L.ByteString+toXml rq = renderLBS def $ case rq of+ StartApplicationSession{..} ->+ doc "StartApplicationSession" nsAppSession+ [xml|+ <applicationInfo>+ <applicationID>#{applicationId}+ <applicationSpecificInfo>+ <acx:SessionLoginInfo xsi:type="acx:SessionLoginInfo">+ <acx:userName>#{userName}+ <acx:password>#{password}+ <acx:sessionCleanupDelay>#{T.pack $ show sessionCleanupDelay}+ <acx:sessionID>#{sessionID}+ <requestedProtocolVersions>+ <protocolVersion>#{getProtocolString requestedProtocolVersion}+ <requestedSessionDuration>#{T.pack $ show requestedSessionDuration}+ |]++ StopApplicationSession{..} ->+ doc "StopApplicationSession" nsAppSession+ [xml|+ <sessionID>#{sessionID}+ <sessionEndReason>+ <definedEndReason>normal+ |]++ ResetApplicationSessionTimer{..} ->+ doc "ResetApplicationSessionTimer" nsAppSession+ [xml|+ <sessionID>#{sessionId}+ <requestedSessionDuration>#{T.pack $ show requestedSessionDuration}+ |]++ GetDeviceId{..} ->+ doc "GetDeviceId" nsACX+ [xml|+ <switchName>#{toText switchName}+ <extension>#{toText extension}+ <controllableByOtherSessions>true+ |]++ GetThirdPartyDeviceId{..} ->+ doc "GetThirdPartyDeviceId" nsACX+ [xml|+ <switchName>#{toText switchName}+ <extension>#{toText extension}+ |]++ MakeCall{..} ->+ doc "MakeCall" acceptedProtocol+ [xml|+ <callingDevice>#{toText callingDevice}+ <calledDirectoryNumber>#{toText calledDirectoryNumber}+ |]++ AnswerCall{..} ->+ doc "AnswerCall" acceptedProtocol+ [xml|+ <callToBeAnswered>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText callId}+ |]++ HoldCall{..} ->+ doc "HoldCall" acceptedProtocol+ [xml|+ <callToBeHeld>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText callId}+ |]++ RetrieveCall{..} ->+ doc "RetrieveCall" acceptedProtocol+ [xml|+ <callToBeRetrieved>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText callId}+ |]++ GenerateDigits{..} ->+ doc "GenerateDigits" acceptedProtocol+ [xml|+ <connectionToSendDigits>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText callId}+ <charactersToSend>#{charactersToSend}+ |]++ ConferenceCall{..} ->+ doc "ConferenceCall" acceptedProtocol+ [xml|+ <heldCall>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText heldCall}+ <activeCall>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText activeCall}+ |]++ SingleStepConferenceCall{..} ->+ doc "SingleStepConferenceCall" acceptedProtocol+ [xml|+ <deviceToJoin>#{toText deviceId}+ <activeCall>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText activeCall}+ <participationType>#{toText participationType}+ |]++ TransferCall{..} ->+ doc "TransferCall" acceptedProtocol+ [xml|+ <heldCall>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText heldCall}+ <activeCall>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText activeCall}+ |]++ ClearConnection{..} ->+ doc "ClearConnection" acceptedProtocol+ [xml|+ <connectionToBeCleared>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText callId}+ |]++ ReleaseDeviceId{..} ->+ doc "ReleaseDeviceId" nsACX+ [xml|+ <device>#{toText device}+ |]++ MonitorStart{..} ->+ case monitorRq of+ Device{..} ->+ doc "MonitorStart" acceptedProtocol+ [xml|+ <monitorObject>+ <deviceObject typeOfNumber="other" mediaClass="notKnown">+ #{toText deviceObject}+ <requestedMonitorFilter>+ <callcontrol>+ <connectionCleared>true+ <conferenced>true+ <delivered>true+ <diverted>true+ <established>true+ <failed>true+ <held>true+ <originated>true+ <retrieved>true+ <transferred>true+ <logicalDeviceFeature>+ <agentReady>true+ <agentWorkingAfterCall>false+ <agentNotReady>true+ <extensions>+ <privateData>+ <private>+ <AvayaEvents>+ <invertFilter>true+ |]+ Session ->+ doc "MonitorStart" acceptedProtocol+ [xml|+ <monitorObject>+ <deviceObject mediaClass="notKnown">+ <extensions>+ <privateData>+ <private>+ <AvayaEvents>+ <invertFilter>true+ <deviceServices>+ <getDeviceIdList>true+ <getMonitorList>true+ <transferMonitorObjects>true+ |]++ MonitorStop{..} ->+ doc "MonitorStop" acceptedProtocol+ [xml|+ <monitorCrossRefID>#{monitorCrossRefID}+ |]++ TransferMonitorObjects{..} ->+ doc "TransferMonitorObjects" acceptedProtocol+ [xml|+ <fromSessionID>#{fromSessionID}+ <toSessionID>#{toSessionID}+ |]++ GetAgentState{..} ->+ doc "GetAgentState" acceptedProtocol+ [xml|+ <device>#{toText device}+ |]++ SetAgentState{..} ->+ doc "SetAgentState" acceptedProtocol+ [xml|+ <device>#{toText device}+ <requestedAgentState>#{toText requestedAgentState}+ |]++ GetCallLinkageData{..} ->+ doc "GetCallLinkageData" acceptedProtocol+ [xml|+ <call>+ <deviceID typeOfNumber="other" mediaClass="notKnown">#{toText deviceId}+ <callID>#{toText callId}+ |]
+ src/DMCC/XML/Response.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE TemplateHaskell #-}++{-| Incoming XML messages (responses and events). -}++module DMCC.XML.Response+ ( Response (..)+ , Event (..)+ , fromXml+ )++where++import DMCC.Prelude++import Control.Exception (SomeException)+import Data.CaseInsensitive (mk)+import Data.List (foldl1')+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as T++import Data.Aeson.TH++import Text.XML+import Text.XML.Cursor++import DMCC.Types+++-- | DMCC response to a request.+data Response+ = UnknownResponse LByteString+ | MalformedResponse LByteString SomeException+ | StartApplicationSessionPosResponse+ { sessionID :: Text+ , actualProtocolVersion :: Text+ , actualSessionDuration :: Int+ }+ | StartApplicationSessionNegResponse+ | GetDeviceIdResponse+ { device :: DeviceId+ }+ | GetThirdPartyDeviceIdResponse+ { device :: DeviceId+ }+ | MonitorStartResponse+ { monitorCrossRefID :: Text+ }+ | MakeCallResponse+ { newCallId :: CallId+ , newUcid :: UCID+ }+ | SingleStepConferenceCallResponse+ { conferencedCall :: CallId+ }+ | GetAgentStateResponse+ { agentState :: Maybe AgentState+ -- ^ Nothing if an unknown state is reported.+ , reasonCode :: Text+ }+ | GetCallLinkageDataResponse+ { linkageUcid :: UCID+ }+ | EventResponse+ { monitorCrossRefID :: Text+ , event :: Event+ }+ -- | Pretty-printed <CSTAErrorCode> message.+ | CSTAErrorCodeResponse+ { errorText :: Text+ }+ deriving Show+++-- | DMCC event.+data Event =+ UnknownEvent+ -- | Precedes every established/cleared event.+ | DeliveredEvent+ { callId :: CallId+ , distributingVdn :: DeviceId+ , ucid :: UCID+ , callingDevice :: DeviceId+ , calledDevice :: DeviceId+ }+ | DivertedEvent+ { callId :: CallId+ }+ | OriginatedEvent+ { callId :: CallId+ , callingDevice :: DeviceId+ , calledDevice :: DeviceId+ }+ | EstablishedEvent+ { callId :: CallId+ }+ | FailedEvent+ { callId :: CallId+ }+ | ConnectionClearedEvent+ { callId :: CallId+ , releasingDevice :: DeviceId+ }+ | HeldEvent+ { callId :: CallId+ }+ | RetrievedEvent+ { callId :: CallId+ }+ | ConferencedEvent+ { primaryOldCall :: CallId+ , secondaryOldCall :: CallId+ }+ | TransferedEvent+ { primaryOldCall :: CallId+ , secondaryOldCall :: CallId+ }+ deriving Show++$(deriveJSON+ defaultOptions{sumEncoding = defaultTaggedObject{tagFieldName="event"}}+ ''Event)++fromXml :: LByteString -> Response+fromXml xml+ = case parseLBS def xml of+ Left err -> MalformedResponse xml err+ Right doc -> let cur = fromDocument doc+ evResp = EventResponse (text cur "monitorCrossRefID")+ in case nameLocalName $ elementName $ documentRoot doc of+ "StartApplicationSessionPosResponse" ->+ StartApplicationSessionPosResponse+ { sessionID = text cur "sessionID"+ , actualProtocolVersion = text cur "actualProtocolVersion"+ , actualSessionDuration = decimal cur "actualSessionDuration"+ }++ "StartApplicationSessionNegResponse" ->+ StartApplicationSessionNegResponse++ "GetDeviceIdResponse" ->+ GetDeviceIdResponse+ { device = DeviceId $ mk $ text cur "device"+ }++ "GetThirdPartyDeviceIdResponse" ->+ GetThirdPartyDeviceIdResponse+ { device = DeviceId $ mk $ text cur "device"+ }++ "MonitorStartResponse" ->+ MonitorStartResponse+ {monitorCrossRefID = text cur "monitorCrossRefID"+ }++ "MakeCallResponse" ->+ MakeCallResponse+ { newCallId = CallId $ textFromPath cur "callingDevice" ["callId"]+ , newUcid =+ UCID $ text cur "globallyUniqueCallLinkageID"+ }++ "SingleStepConferenceCallResponse" ->+ SingleStepConferenceCallResponse+ { conferencedCall =+ CallId $ textFromPath cur "conferencedCall" ["callId"]+ }++ "GetAgentStateResponse" ->+ GetAgentStateResponse+ { agentState =+ let+ raw = textFromPath cur "agentStateList"+ [ "agentStateEntry"+ , "agentInfo"+ , "agentInfoItem"+ , "agentState"+ ]+ state | raw == "agentReady" =+ Just $ Settable Ready+ | raw == "agentWorkingAfterCall" =+ Just $ Settable AfterCall+ | raw == "agentNotReady" =+ Just $ Settable NotReady+ | raw == "agentBusy" =+ Just Busy+ | otherwise = Nothing+ in+ state+ , reasonCode = textFromPath cur "extensions"+ [ "privateData"+ , "private"+ , "GetAgentStateResponsePrivateData"+ , "reasonCode"+ ]+ }++ "GetCallLinkageDataResponse" ->+ GetCallLinkageDataResponse+ { linkageUcid = UCID $ text cur "globallyUniqueCallLinkageID"+ }++ "DeliveredEvent" -> evResp+ DeliveredEvent+ { callId =+ CallId $ textFromPath cur "connection" ["callId"]+ , distributingVdn =+ DeviceId $ mk $+ textFromPath cur "distributingVDN" ["deviceIdentifier"]+ , ucid =+ UCID $ text cur "globallyUniqueCallLinkageID"+ , callingDevice =+ DeviceId $ mk $ textFromPath cur "callingDevice" ["deviceIdentifier"]+ , calledDevice =+ DeviceId $ mk $ textFromPath cur "calledDevice" ["deviceIdentifier"]+ }++ "OriginatedEvent" -> evResp+ OriginatedEvent+ { callId =+ CallId $ textFromPath cur "originatedConnection" ["callId"]+ , callingDevice =+ DeviceId $ mk $ textFromPath cur "callingDevice" ["deviceIdentifier"]+ , calledDevice =+ DeviceId $ mk $ textFromPath cur "calledDevice" ["deviceIdentifier"]+ }++ "DivertedEvent" -> evResp+ DivertedEvent+ { callId =+ CallId $ textFromPath cur "connection" ["callID"]+ }++ "EstablishedEvent" -> evResp+ EstablishedEvent+ { callId =+ CallId $ textFromPath cur "establishedConnection" ["callId"]+ }++ "FailedEvent" -> evResp+ FailedEvent+ { callId =+ CallId $ textFromPath cur "failedConnection" ["callId"]+ }++ "HeldEvent" -> evResp+ HeldEvent+ { callId =+ CallId $ textFromPath cur "heldConnection" ["callId"]+ }++ "RetrievedEvent" -> evResp+ RetrievedEvent+ { callId =+ CallId $ textFromPath cur "retrievedConnection" ["callId"]+ }++ "ConferencedEvent" -> evResp+ ConferencedEvent+ { primaryOldCall =+ CallId $ textFromPath cur "primaryOldCall" ["callId"]+ , secondaryOldCall =+ CallId $ textFromPath cur "secondaryOldCall" ["callId"]+ }++ "TransferedEvent" -> evResp+ TransferedEvent+ { primaryOldCall =+ CallId $ textFromPath cur "primaryOldCall" ["callId"]+ , secondaryOldCall =+ CallId $ textFromPath cur "secondaryOldCall" ["callId"]+ }++ "ConnectionClearedEvent" -> evResp+ ConnectionClearedEvent+ { callId =+ CallId $ textFromPath cur "droppedConnection" ["callId"]+ , releasingDevice =+ DeviceId $ mk $+ textFromPath cur "releasingDevice" ["deviceIdentifier"]+ }++ "CSTAErrorCode" ->+ CSTAErrorCodeResponse+ { errorText =+ let+ msg = T.concat $ cur $// content+ err = case map node (cur $/ checkElement (const True)) of+ (NodeElement el:_) ->+ nameLocalName $ elementName el+ _ -> "CSTAErrorCode"+ in+ T.concat [err, "/", msg]+ }++ _ -> UnknownResponse xml+++text :: Cursor -> Text -> Text+text c n = textFromPath c n []+++decimal :: Cursor -> Text -> Int+decimal c n =+ case T.decimal txt of+ Right (x, "") -> x+ _ -> error $ "Can't parse as decimal: " <> show txt+ where+ txt = text c n :: Text+++-- | Extract contents of the first element which matches provided+-- path (@rootName:extraNames@). Return empty text if no element+-- matches the path.+textFromPath :: Cursor -> Text -> [Text] -> Text+textFromPath cur rootName extraNames =+ fromMaybe "" $ headMay contents+ where+ contents =+ cur $// foldl1' (&/) (map laxElement $ rootName : extraNames) &/ content