plane.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 -- generic AMQP rpc client
   4 import Control.Concurrent
   5 import qualified Control.Exception as X
   6 import Control.Monad
   7 import qualified Data.ByteString.Lazy.Char8 as BL
   8 import qualified Data.Text as T
   9 import Data.Time
  10 import Data.Time.Clock.POSIX
  11 import Data.Version (showVersion)
  12 import Network.AMQP
  13 import Network.AMQP.Utils.Connection
  14 import Network.AMQP.Utils.Helpers
  15 import Network.AMQP.Utils.Options
  16 import Paths_amqp_utils (version)
  17 import System.Environment
  18 import System.Exit
  19
  20 main :: IO ()
  21 main = do
  22   hr "starting"
  23   tid <- myThreadId
  24   args <- getArgs >>= parseargs 'p'
  25   X.onException
  26     (printparam' "timeout" $ show $ timeout args)
  27     (error $ "invalid timeout")
  28   printparam' "client version" $ "amqp-utils " ++ (showVersion version)
  29   printparam' "destination queue" $ tmpQName args
  30   (conn, chan) <- connect args
  31   addChannelExceptionHandler chan (X.throwTo tid)
  32   (q, _, _) <- declareQueue chan newQueue {queueExclusive = True}
  33   ctag <- consumeMsgs chan q NoAck (rpcClientCallback tid args)
  34   printparam' "consumer tag" $ T.unpack ctag
  35   message <- BL.readFile (inputFile args)
  36   now <- getCurrentTime >>= return . floor . utcTimeToPOSIXSeconds
  37   hr "publishing request"
  38   _ <- publishMsg
  39     chan
  40     (T.pack $ currentExchange args)
  41     (T.pack $ tmpQName args)
  42     newMsg
  43       { msgBody = message
  44       , msgReplyTo = Just q
  45       , msgCorrelationID = corrid args
  46       , msgExpiration = msgexp args
  47       , msgTimestamp = Just now
  48       }
  49   hr "waiting for answer"
  50   _ <- forkIO
  51     (threadDelay (floor (1000000 * timeout args)) >>
  52      throwTo tid TimeoutException)
  53   X.catch
  54     (forever $ threadDelay 200000)
  55     (\x -> do
  56        ec <- exceptionHandler x
  57        hr "closing connection"
  58        closeConnection conn
  59        printparam' "exiting" $ show ec
  60        exitWith ec)
  61
  62 exceptionHandler :: RpcException -> IO (ExitCode)
  63 exceptionHandler ReceivedException = return ExitSuccess
  64 exceptionHandler TimeoutException = return $ ExitFailure 1
  65
  66 rpcClientCallback :: ThreadId -> Args -> (Message, Envelope) -> IO ()
  67 rpcClientCallback tid a m@(_, env) = do
  68   let numstring = show $ envDeliveryTag env
  69   hr $ "received " ++ numstring
  70   now <- getZonedTime
  71   _ <-
  72     X.catch
  73       (printmsg m (anRiss a) now)
  74       (\x -> X.throwTo tid (x :: X.SomeException) >> return [])
  75   throwTo tid ReceivedException
  76
  77 data RpcException
  78   = ReceivedException
  79   | TimeoutException
  80   deriving (Show)
  81
  82 instance X.Exception RpcException