arbeite.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 -- generic AMQP rpc server
   3 import Control.Concurrent
   4 import qualified Control.Exception as X
   5 import Control.Monad
   6 import Data.Map (singleton)
   7 import Data.Maybe
   8 import qualified Data.Text as T
   9 import Data.Time
  10 import Data.Version (showVersion)
  11 import Network.AMQP
  12 import Network.AMQP.Types
  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
  19 main :: IO ()
  20 main = do
  21   hr "starting"
  22   tid <- myThreadId
  23   args <- getArgs >>= parseargs 'r'
  24   X.onException
  25     (printparam' "worker" $ fromJust $ fileProcess args)
  26     (error "-X option required")
  27   let addiArgs = reverse $ additionalArgs args
  28   printparam' "client version" $ "amqp-utils " ++ (showVersion version)
  29   (conn, chan) <- connect args
  30   addChannelExceptionHandler chan (X.throwTo tid)
  31   queue <-
  32     maybe
  33       (declareQueue
  34          chan
  35          newQueue {queueExclusive = True, queueName = (T.pack $ tmpQName args)} >>=
  36        (\(x, _, _) -> return x))
  37       (return)
  38       (fmap T.pack (qName args))
  39   printparam' "queue name" $ T.unpack queue
  40   ctag <-
  41     consumeMsgs
  42       chan
  43       queue
  44       (if ack args
  45          then Ack
  46          else NoAck)
  47       (rpcServerCallback tid args addiArgs chan)
  48   printparam' "consumer tag" $ T.unpack ctag
  49   printparam' "send acks" $ show (ack args)
  50   printparam "requeue if rejected" $
  51     if (ack args)
  52       then Just (show (requeuenack args))
  53       else Nothing
  54   hr "entering main loop"
  55   X.catch
  56     (forever $ threadDelay 5000000)
  57     (\exception -> printparam' "exception" $ show (exception :: X.SomeException))
  58   closeConnection conn
  59   hr "connection closed"
  60
  61 rpcServerCallback ::
  62      ThreadId -> Args -> [String] -> Channel -> (Message, Envelope) -> IO ()
  63 rpcServerCallback tid a addi c m@(msg, env) = do
  64   let numstring = show $ envDeliveryTag env
  65   hr $ "BEGIN " ++ numstring
  66   now <- getZonedTime
  67   callbackoptions <-
  68     X.catch
  69       (printmsg m (anRiss a) now)
  70       (\x -> X.throwTo tid (x :: X.SomeException) >> return [])
  71   either (\e -> printparam' "ERROR" (show (e :: X.SomeException))) return =<<
  72     X.try
  73       (optionalFileStuff m callbackoptions addi numstring a tid (Just reply))
  74   hr $ "END " ++ numstring
  75   where
  76     reply e contents = do
  77       void $
  78         publishMsg
  79           c
  80           (envExchangeName env)
  81           (fromJust $ msgReplyTo msg)
  82           newMsg
  83             { msgBody = contents
  84             , msgCorrelationID = msgCorrelationID msg
  85             , msgTimestamp = msgTimestamp msg
  86             , msgExpiration = msgExpiration msg
  87             , msgHeaders = Just $ FieldTable $ singleton "exitcode" $ FVString $ T.pack $ show e
  88             }