printparam -> Flexprint

diff --git a/Network/AMQP/Utils/Connection.hs b/Network/AMQP/Utils/Connection.hs
index 62cba8f46456c11c1a77ae30b1dce66f551c8523..c32f92aa5cfbc909b9d4c5403b261f7976106f24 100644 (file)
--- a/Network/AMQP/Utils/Connection.hs
+++ b/Network/AMQP/Utils/Connection.hs
@@ -17,11 +17,11 @@ import System.X509
 -- | opens a connection and a channel
 connect :: Args -> IO (Connection, Channel)
 connect args = do
-  printparam' "server" $ server args
-  printparam' "port" $ show $ port args
-  printparam' "vhost" $ vHost args
+  printparam "server" $ server args
+  printparam "port" $ port args
+  printparam "vhost" $ vHost args
   printparam "connection_name" $ connectionName args
-  printparam' "connect timeout" $ (show (connect_timeout args)) ++ "s"
+  printparam "connect timeout" $ [show (connect_timeout args), "s"]
   globalCertificateStore <- getSystemCertificateStore
   let myTLS =
         N.TLSSettings
@@ -59,7 +59,7 @@ connect args = do
 
 --  addChannelExceptionHandler chan
 --                             (\exception -> closeConnection conn >>
---                                  printparam' "exiting" (show exception) >>
+--                                  printparam "exiting" (show exception) >>
 --                                  killThread tid)
 --
 -- -- noop sharedValidationCache, handy when debugging
@@ -74,6 +74,6 @@ myCert :: Maybe FilePath -> Maybe FilePath -> t -> IO (Maybe Credential)
 myCert (Just cert') (Just key') _ = do
   result <- credentialLoadX509 cert' key'
   case result of
-    Left x -> printparam' "ERROR" x >> return Nothing
+    Left x -> printparam "ERROR" x >> return Nothing
     Right x -> return $ Just x
 myCert _ _ _ = return Nothing

diff --git a/Network/AMQP/Utils/Helpers.hs b/Network/AMQP/Utils/Helpers.hs
index 19c9b06bfa29b5902786bba8348eeda3b452be29..4ca75a8d23a365cb714f0c0b157cf721378b6a22 100644 (file)
--- a/Network/AMQP/Utils/Helpers.hs
+++ b/Network/AMQP/Utils/Helpers.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE FlexibleInstances #-}
 module Network.AMQP.Utils.Helpers where
 
 import Control.Concurrent
+import qualified Control.Exception as X
 import Control.Monad
 import qualified Data.ByteString.Lazy.Char8 as BL
 import Data.List
@@ -16,35 +18,54 @@ import System.Exit
 import System.IO
 import System.Process
 
--- | log cmdline options
-listToMaybeUnwords :: [String] -> Maybe String
-listToMaybeUnwords [] = Nothing
-listToMaybeUnwords x = Just $ unwords x
+class (Show a) =>
+      Flexprint a
+  where
+  flexprint :: a -> IO ()
+  flexprint = (hPutStrLn stderr) . show
+  empty :: a -> Bool
+  empty _ = False
+  printparam :: String -> a -> IO ()
+  printparam label x =
+    if empty x
+      then return ()
+      else do
+        mapM_ (hPutStr stderr) [" --- ", label, ": "]
+        flexprint x
+        hFlush stderr
+
+instance (Flexprint a) => Flexprint (Maybe a) where
+  empty = isNothing
+  printparam _ Nothing = return ()
+  printparam x (Just y) = printparam x y
+
+instance Flexprint String where
+  flexprint = hPutStrLn stderr
+  empty = null
+
+instance Flexprint [String] where
+  flexprint = flexprint . unwords
+  empty = null
+
+instance Flexprint T.Text where
+  flexprint = flexprint . T.unpack
+  empty = T.null
+
+instance Flexprint BL.ByteString where
+  flexprint x = hPutStrLn stderr "" >> BL.hPut stderr x >> hPutStrLn stderr ""
+  empty = BL.null
+
+instance Flexprint Bool
+
+instance Flexprint Int
 
--- | Strings or ByteStrings with label, oder nothing at all
-printwithlabel :: String -> Maybe (IO ()) -> IO ()
-printwithlabel _ Nothing = return ()
-printwithlabel labl (Just i) = do
-  mapM_ (hPutStr stderr) [" --- ", labl, ": "]
-  i
-  hFlush stderr
+instance Flexprint ExitCode
 
--- | optional parameters
-printparam :: String -> Maybe String -> IO ()
-printparam labl ms = printwithlabel labl $ fmap (hPutStrLn stderr) ms
+instance Flexprint X.SomeException
 
--- | required parameters
-printparam' :: String -> String -> IO ()
-printparam' d s = printparam d (Just s)
+instance Flexprint AMQPException
 
--- | head chars of body
-printbody :: String -> Maybe BL.ByteString -> IO ()
-printbody labl ms = do
-  printwithlabel labl $
-    fmap
-      (\s -> hPutStrLn stderr "" >> BL.hPut stderr s >> hPutStrLn stderr "")
-      ms
-  hFlush stderr
+instance Flexprint ConfirmationResult
 
 -- | log marker
 hr :: String -> IO ()
@@ -114,7 +135,7 @@ printmsg h (msg, envi) anR now = do
     , ("expiration", mexp)
     , ("delivery mode", mdelivmode)
     ]
-  printbody label anriss
+  printparam label anriss
   mapM_ (\hdl -> BL.hPut hdl body >> hFlush hdl) h
   return $
     concat
@@ -212,7 +233,7 @@ optionalFileStuff (msg, envi) callbackoptions addi numstring a tid action = do
           (constructCallbackCmdLine callbackoptions addi numstring)
           (fileProcess a)
           path
-  printparam "calling" $ fmap unwords callbackcmdline
+  printparam "calling" callbackcmdline
   maybe
     (acke envi a)
     (\c ->
@@ -253,7 +274,7 @@ doProc a numstring envi (exe:args) action = do
     createProcess (proc exe args) {std_out = out, std_err = Inherit}
   sout <- mapM BL.hGetContents h
   exitcode <- maybe 0 id (fmap BL.length sout) `seq` waitForProcess processhandle
-  printparam' (numstring ++ " call returned") $ show exitcode
+  printparam (numstring ++ " call returned") exitcode
   if isJust action && isJust sout
     then ((fromJust action $ exitcode) (fromJust sout)) >> acke envi a
     else case exitcode of

diff --git a/agitprop.hs b/agitprop.hs
index 233e881d278fa82b3490add63cb3fee7e6713370..4b2aa43727f31f740962e84a7f54e4b55b9a3c7a 100644 (file)
--- a/agitprop.hs
+++ b/agitprop.hs
@@ -31,23 +31,25 @@ main = do
   hr "starting"
   tid <- myThreadId
   args <- getArgs >>= parseargs 'a'
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
-  printparam' "routing key" $ rKey args
-  printparam' "exchange" $ currentExchange args
+  printparam "client version" ["amqp-utils", showVersion version]
+  printparam "routing key" $ rKey args
+  printparam "exchange" $ currentExchange args
   isDir <-
     if inputFile args == "-"
       then return False
       else F.getFileStatus (inputFile args) >>= return . F.isDirectory
   if isDir
-    then printparam' "hotfolder" $ inputFile args
-    else printparam' "input file" $
-         (inputFile args) ++
-         if (lineMode args)
-           then " (line-by-line)"
-           else ""
+    then printparam "hotfolder" $ inputFile args
+    else printparam
+           "input file"
+           [ inputFile args
+           , if (lineMode args)
+               then "(line-by-line)"
+               else ""
+           ]
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
-  printparam' "confirm mode" $ show $ confirm args
+  printparam "confirm mode" $ confirm args
   if (confirm args)
     then do
       confirmSelect chan False
@@ -85,26 +87,27 @@ main = do
     exceptionHandler
   -- all done. wait and close.
   if (confirm args)
-    then waitForConfirms chan >>= (printparam' "confirmed") . show
+    then waitForConfirms chan >>= printparam "confirmed"
     else return ()
   X.catch (closeConnection conn) exceptionHandler
 
 -- | A handler for clean exit
 exceptionHandler :: AMQPException -> IO ()
-exceptionHandler (ChannelClosedException Normal txt) = printparam' "exit" txt >> exitWith ExitSuccess
-exceptionHandler (ConnectionClosedException Normal txt) = printparam' "exit" txt >> exitWith ExitSuccess
-exceptionHandler x = printparam' "exception" (show x) >> exitWith (ExitFailure 1)
+exceptionHandler (ChannelClosedException Normal txt) = printparam "exit" txt >> exitWith ExitSuccess
+exceptionHandler (ConnectionClosedException Normal txt) = printparam "exit" txt >> exitWith ExitSuccess
+exceptionHandler x = printparam "exception" x >> exitWith (ExitFailure 1)
 
 -- | The handler for publisher confirms
 confirmCallback :: (Word64, Bool, AckType) -> IO ()
 confirmCallback (deliveryTag, isAll, ackType) =
-  printparam'
+  printparam
     "confirmed"
-    ((show deliveryTag) ++
-     (if isAll
-        then " all "
-        else " this ") ++
-     (show ackType))
+    [ show deliveryTag
+    , if isAll
+        then "all"
+        else "this"
+    , show ackType
+    ]
 
 -- | Hotfolder event handler
 handleEvent ::
@@ -134,9 +137,7 @@ handleFile f s@(_:_) x =
 handleFile f [] x =
   X.catch
     (BL.readFile x >>= f (Just x))
-    (\exception ->
-       printparam' "exception in handleFile" $
-       show (exception :: X.SomeException))
+    (\e -> printparam "exception in handleFile" (e :: X.SomeException))
 
 -- | Publish one message with our settings
 publishOneMsg' :: Channel -> Args -> Maybe String -> BL.ByteString -> IO ()
@@ -153,29 +154,28 @@ publishOneMsg' c a fn f = do
         return (Just (T.pack t), Just (T.pack e))
       else return ((contenttype a), (contentencoding a))
   now <- getCurrentTime >>= return . floor . utcTimeToPOSIXSeconds
-  r <-
-    publishMsg
-      c
-      (T.pack $ currentExchange a)
-      (T.pack $ rKey a)
-      newMsg
-        { msgBody = f
-        , msgDeliveryMode = persistent a
-        , msgTimestamp = Just now
-        , msgID = msgid a
-        , msgType = msgtype a
-        , msgUserID = userid a
-        , msgApplicationID = appid a
-        , msgClusterID = clusterid a
-        , msgContentType = mtype
-        , msgContentEncoding = mencoding
-        , msgReplyTo = replyto a
-        , msgPriority = prio a
-        , msgCorrelationID = corrid a
-        , msgExpiration = msgexp a
-        , msgHeaders = substheader (fnheader a) fn $ msgheader a
-        }
-  printparam "sent" $ fmap show r
+  publishMsg
+    c
+    (T.pack $ currentExchange a)
+    (T.pack $ rKey a)
+    newMsg
+      { msgBody = f
+      , msgDeliveryMode = persistent a
+      , msgTimestamp = Just now
+      , msgID = msgid a
+      , msgType = msgtype a
+      , msgUserID = userid a
+      , msgApplicationID = appid a
+      , msgClusterID = clusterid a
+      , msgContentType = mtype
+      , msgContentEncoding = mencoding
+      , msgReplyTo = replyto a
+      , msgPriority = prio a
+      , msgCorrelationID = corrid a
+      , msgExpiration = msgexp a
+      , msgHeaders = substheader (fnheader a) fn $ msgheader a
+      } >>=
+    printparam "sent"
   where
     substheader ::
          [String] -> Maybe String -> Maybe FieldTable -> Maybe FieldTable

diff --git a/arbeite.hs b/arbeite.hs
index 1969006d432ef01daf8af6948a7d372dd0ab4fed..361a961809caab6d07bcef280cc61bc91e5289a6 100644 (file)
--- a/arbeite.hs
+++ b/arbeite.hs
@@ -22,10 +22,10 @@ main = do
   tid <- myThreadId
   args <- getArgs >>= parseargs 'r'
   X.onException
-    (printparam' "worker" $ fromJust $ fileProcess args)
+    (printparam "worker" $ fromJust $ fileProcess args)
     (error "-X option required")
   let addiArgs = reverse $ additionalArgs args
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
+  printparam "client version" ["amqp-utils", showVersion version]
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
   queue <-
@@ -36,10 +36,10 @@ main = do
        (\(x, _, _) -> return x))
       (return)
       (fmap T.pack (qName args))
-  printparam' "queue name" $ T.unpack queue
+  printparam "queue name" queue
   if (currentExchange args /= "")
     then do
-      printparam' "exchange" $ currentExchange args
+      printparam "exchange" $ currentExchange args
       bindQueue chan queue (T.pack $ currentExchange args) queue
     else return ()
   ctag <-
@@ -50,16 +50,16 @@ main = do
          then Ack
          else NoAck)
       (rpcServerCallback tid args addiArgs chan)
-  printparam' "consumer tag" $ T.unpack ctag
-  printparam' "send acks" $ show (ack args)
+  printparam "consumer tag" ctag
+  printparam "send acks" $ ack args
   printparam "requeue if rejected" $
     if (ack args)
-      then Just (show (requeuenack args))
+      then Just (requeuenack args)
       else Nothing
   hr "entering main loop"
   X.catch
     (forever $ threadDelay 5000000)
-    (\exception -> printparam' "exception" $ show (exception :: X.SomeException))
+    (\e -> printparam "exception" (e :: X.SomeException))
   closeConnection conn
   hr "connection closed"
 
@@ -73,7 +73,7 @@ rpcServerCallback tid a addi c m@(msg, env) = do
     X.catch
       (printmsg Nothing m (anRiss a) now)
       (\x -> X.throwTo tid (x :: X.SomeException) >> return [])
-  either (\e -> printparam' "ERROR" (show (e :: X.SomeException))) return =<<
+  either (\e -> printparam "ERROR" (e :: X.SomeException)) return =<<
     X.try
       (optionalFileStuff m callbackoptions addi numstring a tid (Just reply))
   hr $ "END " ++ numstring

diff --git a/konsum.hs b/konsum.hs
index 10b321eb9e6ff0c72da69b498af8f483ba7b107d..1c0f933b5e291c53b5514422e72fe86d59205b01 100644 (file)
--- a/konsum.hs
+++ b/konsum.hs
@@ -18,11 +18,11 @@ main = do
   tid <- myThreadId
   args <- getArgs >>= parseargs 'k'
   let addiArgs = reverse $ additionalArgs args
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
+  printparam "client version" ["amqp-utils", showVersion version]
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
   -- set prefetch
-  printparam' "prefetch" $ show $ preFetch args
+  printparam "prefetch" $ preFetch args
   qos chan 0 (fromIntegral $ preFetch args) False
   -- attach to given queue? or build exclusive queue and bind it?
   queue <-
@@ -30,11 +30,11 @@ main = do
       (tempQueue chan (tmpQName args) (bindings args) (currentExchange args))
       (return)
       (fmap T.pack (qName args))
-  printparam' "queue name" $ T.unpack queue
-  printparam "shown body chars" $ fmap show $ anRiss args
+  printparam "queue name" queue
+  printparam "shown body chars" $ anRiss args
   printparam "temp dir" $ tempDir args
   printparam "callback" $ fileProcess args
-  printparam "callback args" $ listToMaybeUnwords addiArgs
+  printparam "callback args" $ addiArgs
   -- subscribe to the queue
   ctag <-
     consumeMsgs
@@ -44,8 +44,8 @@ main = do
          then Ack
          else NoAck)
       (myCallback args addiArgs tid)
-  printparam' "consumer tag" $ T.unpack ctag
-  printparam' "send acks" $ show (ack args)
+  printparam "consumer tag" ctag
+  printparam "send acks" $ ack args
   printparam "requeue if rejected" $
     if (ack args)
       then Just (show (requeuenack args))
@@ -53,7 +53,7 @@ main = do
   hr "entering main loop"
   X.catch
     (forever $ threadDelay 5000000)
-    (\exception -> printparam' "exception" $ show (exception :: X.SomeException))
+    (\e -> printparam "exception" (e :: X.SomeException))
   closeConnection conn
   hr "connection closed"
 
@@ -67,7 +67,7 @@ tempQueue chan tmpqname bindlist x = do
   mapM_
     (\(xchange, bkey) ->
        bindQueue chan q (T.pack xchange) (T.pack bkey) >>
-       printparam' "binding" (xchange ++ ":" ++ bkey))
+       printparam "binding" [xchange, bkey])
     (if null bindlist
        then [(x, "#")]
        else bindlist)
@@ -84,7 +84,7 @@ myCallback a addi tid m@(_, envi) = do
       (printmsg Nothing m (anRiss a) now)
       (\x -> X.throwTo tid (x :: X.SomeException) >> return [])
   either
-    (\e -> printparam' "ERROR" (show (e :: X.SomeException)) >> reje envi a)
+    (\e -> printparam "ERROR" (e :: X.SomeException) >> reje envi a)
     return =<<
     X.try (optionalFileStuff m callbackoptions addi numstring a tid Nothing)
   hr $ "END " ++ numstring

diff --git a/plane.hs b/plane.hs
index edf50197f2a0e5ad7f35c062585f86a622165883..045bd0ae763bbfe58763bd9c7176ac8bc2b28548 100644 (file)
--- a/plane.hs
+++ b/plane.hs
@@ -24,27 +24,27 @@ main = do
   tid <- myThreadId
   args <- getArgs >>= parseargs 'p'
   X.onException
-    (printparam' "rpc_timeout" $ show (rpc_timeout args) ++ "s")
+    (printparam "rpc_timeout" [show (rpc_timeout args), "s"])
     (error $ "invalid rpc_timeout")
-  printparam' "client version" $ "amqp-utils " ++ (showVersion version)
-  printparam' "destination queue" $ tmpQName args
+  printparam "client version" ["amqp-utils", showVersion version]
+  printparam "destination queue" $ tmpQName args
   (conn, chan) <- connect args
   addChannelExceptionHandler chan (X.throwTo tid)
   (q, _, _) <- declareQueue chan newQueue {queueExclusive = True}
   if (currentExchange args /= "")
     then do
-      printparam' "exchange" $ currentExchange args
+      printparam "exchange" $ currentExchange args
       bindQueue chan q (T.pack $ currentExchange args) q
     else return ()
-  printparam' "input file" $ inputFile args
+  printparam "input file" $ inputFile args
   message <-
     if inputFile args == "-"
       then BL.getContents
       else BL.readFile (inputFile args)
-  printparam' "output file" $ outputFile args
+  printparam "output file" $ outputFile args
   h <- if outputFile args == "-" then return stdout else openBinaryFile (outputFile args) WriteMode
   ctag <- consumeMsgs chan q NoAck (rpcClientCallback h tid args)
-  printparam' "consumer tag" $ T.unpack ctag
+  printparam "consumer tag" ctag
   now <- getCurrentTime >>= return . floor . utcTimeToPOSIXSeconds
   hr "publishing request"
   _ <- publishMsg
@@ -69,7 +69,7 @@ main = do
        ec <- exceptionHandler x
        hr "closing connection"
        closeConnection conn
-       printparam' "exiting" $ show ec
+       printparam "exiting" ec
        exitWith ec)
 
 exceptionHandler :: RpcException -> IO (ExitCode)