AMI (empty) → 0.1

raw patch · 5 files changed

+445/−0 lines, 5 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, mtl, network, pureMD5, stm

Files

• AMI.cabal +49/−0
• LICENSE +30/−0
• Network/AMI.hs +334/−0
• Setup.hs +2/−0
• test.hs +30/−0

@@ -0,0 +1,49 @@+Name:                AMI++Version:             0.1++Synopsis:            Low-level bindings for Asterisk Manager Interface (AMI).++Description:         This package provides simple low-level bindings for+                     Asterisk Manager Interface (AMI).++Homepage:            http://redmine.iportnov.ru/projects/ami++bug-reports: http://redmine.iportnov.ru/projects/ami++License:             BSD3++License-file:        LICENSE++Author:              IlyaPortnov++Maintainer:          portnov84@rambler.ru++-- A copyright notice.+-- Copyright:           ++Category:            Network++Build-type:          Simple++Extra-source-files:  test.hs++Cabal-version:       >=1.6+++Library+  Exposed-modules:     Network.AMI+  +  Build-depends:       base >= 4 && < 5, containers, mtl, network, bytestring,+                       pureMD5, stm+  +  -- Modules not exported by this package.+  -- Other-modules:       +  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         ++Source-repository head+  type: git+  location: git://home.iportnov.ru/AMI.git+

@@ -0,0 +1,30 @@+Copyright (c)2012, IlyaPortnov++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 IlyaPortnov 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.

@@ -0,0 +1,334 @@+{-# LANGUAGE OverloadedStrings, BangPatterns #-}+module Network.AMI+  (-- * Usage+   -- $usage++   -- * Types+   Parameters,+   ActionType, EventType,+   ActionID, ResponseType,+   EventHandler,+   AMI,+   Action (..),+   Response (..),+   Event (..),+   ConnectInfo (..),+   -- * Functions+   withAMI, withAMI_MD5,+   query,+   handleEvent+  ) where++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Instances+import Control.Monad.Reader+import Control.Concurrent+import Control.Concurrent.STM+import qualified Control.Exception as E+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L+import Data.Digest.Pure.MD5+import System.IO.Unsafe (unsafePerformIO)+import Network+import Network.Socket+import System.IO++{- $usage+ +> import Network.AMI+> +> info :: ConnectInfo+> info = ConnectInfo {+>          ciHost = "localhost"+>        , ciPort = 5038+>        , ciUsername = "admin"+>        , ciSecret = "PASSWORD" }+> +> main :: IO ()+> main = withAMI_MD5 info $ do+>   handleEvent "FullyBooted" onBooted+>   mail <- query "MailboxCount" [("Mailbox","900")]+>   liftIO $ print mail+>   jabber <- query "JabberSend" [("Jabber", "asterisk"),+>                          ("JID", "someone@example.com"),+>                          ("ScreenName", "asterisk"),+>                          ("Message", "Jabber via AMI")]+>   liftIO $ print jabber+> +> onBooted :: EventHandler+> onBooted ps = liftIO $ do+>   putStrLn "Asterisk is fully booted."+>   print ps+ + -}++-- | Action or response or event parameters+type Parameters = [(B.ByteString, B.ByteString)]++type ActionType = B.ByteString++type EventType = B.ByteString++type ActionID = Integer++type ResponseType = B.ByteString++type EventHandler = Parameters -> IO ()++-- | Action packet (sent to Asterisk)+data Action = Action ActionID ActionType Parameters+  deriving (Eq, Show)++-- | Response packet (received from Asterisk)+data Response = Response ActionID ResponseType Parameters [B.ByteString]+  deriving (Eq, Show)++-- | Event packet (received from Asterisk)+data Event = Event EventType Parameters+  deriving (Eq, Show)++-- | AMI monad internal state+data AMIState = AMIState {+    amiHandle :: Maybe Handle                        -- ^ Handle for socket of Asterisk connection+  , amiActionID :: ActionID                          -- ^ ActionID of last action+  , amiResponses :: M.Map ActionID (Maybe Response)  -- ^ Responses for sent actions+  , amiEventHandlers :: M.Map EventType EventHandler -- ^ Event handlers+  }++-- | Info needed to connect and authenticate in Asterisk+data ConnectInfo = ConnectInfo {+    ciHost :: String           -- ^ Host with Asterisk server (e.g. `localhost')+  , ciPort :: Int              -- ^ Port of Asterisk server (usually 5038)+  , ciUsername :: B.ByteString -- ^ Username+  , ciSecret :: B.ByteString   -- ^ Secret+  } deriving (Eq, Show)++-- | The AMI monad+type AMI a = ReaderT (TVar AMIState) IO a++packID :: ActionID -> B.ByteString+packID i = B.pack (show i)++-- | Sort-of Control.Monad.State.gets+getAMI :: (AMIState -> a) -> AMI a+getAMI fn = do+  var <- ask+  st <- liftIO $ atomically $ readTVar var+  return (fn st)++-- | Sort-of Control.Monad.State.put+putAMI :: AMIState -> AMI ()+putAMI st = do+  var <- ask+  liftIO $ atomically $ writeTVar var st++-- | Sort-of Control.Monad.State.modify+modifyAMI :: (AMIState -> AMIState) -> AMI ()+modifyAMI fn = do+  st <- getAMI id+  putAMI (fn st)++-- | Return next ActionID+inc :: AMI ActionID+inc = do+  st <- getAMI id+  let n = 1 + amiActionID st+  putAMI $ st {amiActionID = n}+  return n++-- | Get connection handle+getHandle :: AMI Handle+getHandle = do+  mbh <- getAMI amiHandle+  case mbh of+    Nothing -> fail "Connection is not opened"+    Just h -> return h++-- | Add an event handler+handleEvent :: EventType -> EventHandler -> AMI ()+handleEvent t handler = modifyAMI add+  where+    add st = st {amiEventHandlers = M.insert t handler (amiEventHandlers st)}++-- | Send an Action packet and return the response.+--+-- CAUTION: the response value should be evaluated in order+-- to be removed from internal responses queue. Leaving+-- response value un-evaluated (e.g. unused) will cause+-- memory leak.+--+query :: ActionType -> Parameters -> AMI Response+query t ps = do+  i <- inc+  var <- ask+  liftIO $ atomically $ do+      st <- readTVar var+      let resps = M.insert i Nothing (amiResponses st)+      writeTVar var $ st {amiResponses = resps}++  h <- getHandle+  liftIO $ sendPacket h (Action i t ps)+  return $ unsafePerformIO $ do+    st <- atomically $ readTVar var+    atomically $ do +      st <- readTVar var+      let resps = amiResponses st+      case M.lookup i resps of+        Just (Just a) -> do+           writeTVar var $ st {amiResponses = M.delete i resps}+           return a+        Just (Nothing) -> retry+        Nothing -> fail $ "There was no response for Action " ++ show i++-- | Open a connection to Asterisk and authenticate+open :: ConnectInfo -> AMI ThreadId+open info = do+    h <- liftIO $ connectTo (ciHost info) (PortNumber $ fromIntegral $ ciPort info)+    t <- forkAnswersReader h+    modifyAMI $ \st -> st {amiHandle = Just h}+    s <- liftIO $ B.hGetLine h+    auth <- query "Login" [("Username", ciUsername info), ("Secret", ciSecret info)]+    case auth of+      Response _ "Success" _ _ -> return t+      _ -> fail "Authentication failed"++-- | Open a connection to Asterisk and authenticate using MD5 challenge+openMD5 :: ConnectInfo -> AMI ThreadId+openMD5 info = do+    h <- liftIO $ connectTo (ciHost info) (PortNumber $ fromIntegral $ ciPort info)+    s <- liftIO $ B.hGetLine h+    t <- forkAnswersReader h+    modifyAMI $ \st -> st {amiHandle = Just h}+    chp <- query "Challenge" [("AuthType", "md5")]+    case chp of+      Response _ "Success" [("Challenge", ch)] _ -> do+        let key = B.pack $ show $ md5 $ L.fromChunks [ch `B.append` ciSecret info]+        auth <- query "Login" [("AuthType", "md5"),+                            ("Username", ciUsername info),+                            ("Key", key)]+        case auth of+          Response _ "Success" _ _ -> return t+          x -> fail $ "MD5 authentication failed: " ++ show x+      _ -> fail "Cannot get challenge for MD5 authentication"++-- | Close Asterisk connection+close :: ThreadId -> AMI ()+close t = do+  !x <- query "Logoff" [] +  h <- getHandle+  modifyAMI $ \st -> st {amiHandle = Nothing}+  rs <- getAMI amiResponses+  liftIO $ killThread t+  liftIO $ hClose h++-- | Connect, execute acions, disconnect+withAMI :: ConnectInfo -> AMI a -> IO a+withAMI info ami = runAMI $ do+    t <- open info+    r <- ami+    close t+    return r++-- | Connect (using MD5 challenge), execute acions, disconnect+withAMI_MD5 :: ConnectInfo -> AMI a -> IO a+withAMI_MD5 info ami = runAMI $ do+    t <- openMD5 info+    r <- ami+    close t+    return r++-- | Send one AMI packet+sendPacket :: Handle -> Action -> IO ()+sendPacket h p = do+  let s = format p `B.append` "\r\n"+  B.hPutStr h s+  B.hPutStr h "\r\n"+  hFlush h++-- | Run AMI actions+runAMI :: AMI a -> IO a+runAMI ami = do+  var <- atomically $ newTVar (AMIState Nothing 0 M.empty M.empty)+  runReaderT ami var++readUntilEmptyLine :: Handle -> IO B.ByteString+readUntilEmptyLine h = do+  str <- B.hGetLine h `E.catch` \(E.SomeException _) -> return "\n"+  if (str == "\n") || (str == "\r") || (str == "\r\n")+    then return str+    else do+         next <- readUntilEmptyLine h+         return $ str `B.append` next++forkAnswersReader :: Handle -> AMI ThreadId+forkAnswersReader h = do+    var <- ask+    liftIO $ forkIO (forever $ reader h var)+  where+    reader :: Handle -> TVar AMIState -> IO ()+    reader h var = do+      str <- readUntilEmptyLine h+      case parse str of+        Left err -> do+                    putStrLn $ "Error parsing answer: " ++ err+                    return ()+        Right (Right p@(Response i _ _ _)) -> do+          atomically $ do+            st <- readTVar var+            let resps = M.insert i (Just p) (amiResponses st)+            writeTVar var $ st {amiResponses = resps}+        Right (Left p@(Event t ps)) -> do+            st <- atomically $ readTVar var+            case M.lookup t (amiEventHandlers st) of+              Nothing -> return ()+              Just handler -> handler ps++linesB y = h : if B.null t then [] else linesB (B.drop 2 t)+   where (h,t) = B.breakSubstring "\r\n" y++parse :: B.ByteString -> Either String (Either Event Response)+parse str = uncurry toPacket =<< (toPairs [] $ B.split '\r' str)+  where+    toPairs :: Parameters -> [B.ByteString] -> Either String (Parameters, [B.ByteString])+    toPairs [] [] = Left "Empty packet"+    toPairs acc [] = Right (acc, [])+    toPairs acc (s:ss) =+      case B.split ':' s of+        []     -> return (acc, [])+        [n,v]  -> let new = (n, B.dropWhile (== ' ') v)+                  in  toPairs (acc ++ [new]) ss+        x      -> Right (acc, (s:ss))++    toPacket :: Parameters -> [B.ByteString] -> Either String (Either Event Response)+    toPacket [] text = Right $ Right $ Response 0 "text" [] text+    toPacket ((k,v):pairs) text =+      case k of+        "Response" -> toResponse v pairs text+        "Event"    -> toEvent    v pairs+        _          -> Left  $ "Invalid first parameter: " ++ show v++    getField :: B.ByteString -> Parameters -> Either String (B.ByteString, Parameters)+    getField x ps = go x [] ps++    go x acc [] = Left "No field in packet"+    go x acc ((k,v):rest)+      | x == k    = Right (v, acc ++ rest)+      | otherwise = go x ((k,v):acc) rest++    toResponse name pairs text = do+      (i, ps) <- getField "ActionID" pairs+      return $ Right $ Response (read $ B.unpack i) name ps text++    toEvent name pairs = Right $ Left $ Event name pairs++format :: Action -> B.ByteString+format (Action i name ps) =+    formatParams $ [("Action", name), ("ActionID", packID i)] ++ ps++formatParams :: Parameters -> B.ByteString+formatParams pairs = B.intercalate "\r\n" $ map one pairs+  where+    one (k,v) = k `B.append` ": " `B.append` v+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}+import Control.Monad.Trans+import Control.Concurrent++import Network.AMI++info = ConnectInfo {+         ciHost = "localhost",+         ciPort = 5038,+         ciUsername = "monitor",+         ciSecret = "PASSWORD" }++main = do+  forkIO test+  threadDelay 150+  test++test = withAMI_MD5 info $ do+  handleEvent "FullyBooted" onBooted+  mail <- query "MailboxCount" [("Mailbox","900")]+  liftIO $ print mail+  jabber <- query "JabberSend" [("Jabber", "asterisk"),+                           ("JID", "portnov@free-alt.ru"),+                           ("ScreenName", "asterisk"),+                           ("Message", "Jabber via AMI")]+  liftIO $ print jabber++onBooted ps = liftIO $ do+  putStrLn "Asterisk is fully booted."+  print ps