filename header option

diff --git a/Network/AMQP/Utils/Options.hs b/Network/AMQP/Utils/Options.hs
index 5545aaf68354f1e6449cc054ace9cbdb0baccc86..1544e677b9323b93c225cef901a403e623b0239a 100644 (file)
--- a/Network/AMQP/Utils/Options.hs
+++ b/Network/AMQP/Utils/Options.hs
@@ -47,6 +47,7 @@ data Args = Args
   , msgcorrid :: Maybe Text
   , msgexp :: Maybe Text
   , msgheader :: Maybe FieldTable
+  , fnheader :: Maybe String
   }
 
 instance Default Args where
@@ -88,6 +89,7 @@ instance Default Args where
       Nothing
       Nothing
       Nothing
+      Nothing
 
 -- | Common options
 cOptions :: [OptDescr (Args -> Args)]
@@ -293,17 +295,24 @@ aOptions =
       ["header"]
       (ReqArg (\s o -> o {msgheader = addheader (msgheader o) s}) "HEADER=VALUE")
       ("Message Headers")
+  , Option
+      ['F']
+      ["fnheader"]
+      (ReqArg (\s o -> o {fnheader = Just s}) "HEADERNAME")
+      ("Message Header for filename")
   ]
 
--- |
+-- | Options for the executables
 options :: String -> [OptDescr (Args -> Args)]
 options "konsum" = kOptions ++ cOptions
 options "agitprop" = aOptions ++ cOptions
 options _ = cOptions
 
+-- | Add a header with a String value
 addheader :: Maybe FieldTable -> String -> Maybe FieldTable
 addheader Nothing string = Just $ FieldTable $ M.singleton (k string) (v string)
-addheader (Just (FieldTable oldheader)) string = Just $ FieldTable $ M.insert (k string) (v string) oldheader
+addheader (Just (FieldTable oldheader)) string =
+  Just $ FieldTable $ M.insert (k string) (v string) oldheader
 
 k :: String -> Text
 k s = pack $ takeWhile (/='=') s

diff --git a/agitprop.hs b/agitprop.hs
index 894f248b4b6c04a618c74a54776521906e5ed0dd..03f0e4a8b7daabc0d930d33a50c4abe391cc2fb6 100644 (file)
--- a/agitprop.hs
+++ b/agitprop.hs
@@ -5,9 +5,12 @@ import qualified Control.Exception as X
 import Control.Monad (forever)
 import qualified Data.ByteString.Lazy.Char8 as BL
 import qualified Data.Text as T
+import Data.Time
+import Data.Time.Clock.POSIX
 import Data.Version (showVersion)
 import Data.Word (Word64)
 import Network.AMQP
+import Network.AMQP.Types
 import Network.AMQP.Utils.Connection
 import Network.AMQP.Utils.Helpers
 import Network.AMQP.Utils.Options
@@ -15,8 +18,6 @@ import Paths_amqp_utils (version)
 import System.Environment
 import System.INotify
 import qualified System.Posix.Files as F
-import Data.Time
-import Data.Time.Clock.POSIX
 
 main :: IO ()
 main = do
@@ -57,8 +58,8 @@ main = do
          hr $ "sending " ++ (inputFile args)
          messageFile <- BL.readFile (inputFile args)
          if (lineMode args)
-           then mapM_ publishOneMsg (BL.lines messageFile)
-           else publishOneMsg messageFile)
+           then mapM_ (publishOneMsg Nothing) (BL.lines messageFile)
+           else publishOneMsg (Just (inputFile args)) messageFile)
     (\exception -> printparam' "exception" $ show (exception :: X.SomeException))
   -- all done. wait and close.
   if (confirm args)
@@ -78,45 +79,51 @@ confirmCallback (deliveryTag, isAll, ackType) =
      (show ackType))
 
 -- | Hotfolder event handler
-handleEvent :: (BL.ByteString -> IO ()) -> Event -> IO ()
+handleEvent :: (Maybe String -> BL.ByteString -> IO ()) -> Event -> IO ()
 -- just handle closewrite and movedin events
 handleEvent f (Closed False (Just x) True) = handleFile f x
 handleEvent f (MovedIn False x _) = handleFile f x
 handleEvent _ _ = return ()
 
 -- | Hotfolder file handler
-handleFile :: (BL.ByteString -> IO ()) -> FilePath -> IO ()
+handleFile :: (Maybe String -> BL.ByteString -> IO ()) -> FilePath -> IO ()
 handleFile _ ('.':_) = return () -- ignore hidden files
 handleFile f x =
   X.catch
-    (hr ("sending " ++ x) >> BL.readFile x >>= f)
+    (hr ("sending " ++ x) >> BL.readFile x >>= f (Just x))
     (\exception ->
        printparam' "exception in handleFile" $
        show (exception :: X.SomeException))
 
 -- | Publish one message with our settings
-publishOneMsg' :: Channel -> Args -> BL.ByteString -> IO ()
-publishOneMsg' c a f = do
-      now <- getCurrentTime >>= return.floor.utcTimeToPOSIXSeconds
-      r <-
-        publishMsg
-          c
-          (T.pack $ currentExchange a)
-          (T.pack $ rKey a)
-          newMsg { msgBody = f
-                 , msgDeliveryMode = Just Persistent
-                 , msgTimestamp = Just now
-                 , msgID = msgid a
-                 , msgType = msgtype a
-                 , msgUserID = msguserid a
-                 , msgApplicationID = msgappid a
-                 , msgClusterID = msgclusterid a
-                 , msgContentType = msgcontenttype a
-                 , msgContentEncoding = msgcontentencoding a
-                 , msgReplyTo = msgreplyto a
-                 , msgPriority = msgprio a
-                 , msgCorrelationID = msgcorrid a
-                 , msgExpiration = msgexp a
-                 , msgHeaders = msgheader a
-                 }
-      printparam "sent" $ fmap show r
+publishOneMsg' :: Channel -> Args -> Maybe String -> BL.ByteString -> IO ()
+publishOneMsg' c a fn f = do
+  now <- getCurrentTime >>= return . floor . utcTimeToPOSIXSeconds
+  r <-
+    publishMsg
+      c
+      (T.pack $ currentExchange a)
+      (T.pack $ rKey a)
+      newMsg
+        { msgBody = f
+        , msgDeliveryMode = Just Persistent
+        , msgTimestamp = Just now
+        , msgID = msgid a
+        , msgType = msgtype a
+        , msgUserID = msguserid a
+        , msgApplicationID = msgappid a
+        , msgClusterID = msgclusterid a
+        , msgContentType = msgcontenttype a
+        , msgContentEncoding = msgcontentencoding a
+        , msgReplyTo = msgreplyto a
+        , msgPriority = msgprio a
+        , msgCorrelationID = msgcorrid a
+        , msgExpiration = msgexp a
+        , msgHeaders = substheader (fnheader a) fn $ msgheader a
+        }
+  printparam "sent" $ fmap show r
+  where
+    substheader ::
+         Maybe String -> Maybe String -> Maybe FieldTable -> Maybe FieldTable
+    substheader (Just fnh) (Just fname) old = addheader old (fnh ++ "=" ++ fname)
+    substheader _ _ old = old