agitprop: file magic

diff --git a/Network/AMQP/Utils/Options.hs b/Network/AMQP/Utils/Options.hs
index bc2aedfa8fc7258fc7ca1cd7b48ca6c6d9dce3bf..cc819fdbe64dcf97e6ddc4919c7fdcb38a0be012 100644 (file)
--- a/Network/AMQP/Utils/Options.hs
+++ b/Network/AMQP/Utils/Options.hs
@@ -1,8 +1,8 @@
 module Network.AMQP.Utils.Options where
 
 import Data.Default.Class
-import Data.Maybe
 import qualified Data.Map as M
+import Data.Maybe
 import Data.Text (Text, pack)
 import Data.Version (showVersion)
 import Network.AMQP.Types
@@ -46,8 +46,9 @@ data Args = Args
   , corrid :: Maybe Text
   , msgexp :: Maybe Text
   , msgheader :: Maybe FieldTable
-  , fnheader :: [ String ]
-  , suffix :: [ String ]
+  , fnheader :: [String]
+  , suffix :: [String]
+  , magic :: Bool
   }
 
 instance Default Args where
@@ -90,6 +91,7 @@ instance Default Args where
       Nothing
       []
       []
+      False
 
 -- | Common options
 cOptions :: [OptDescr (Args -> Args)]
@@ -232,74 +234,77 @@ aOptions =
       []
       ["msgid"]
       (ReqArg (\s o -> o {msgid = Just $ pack s}) "ID")
-      ("Message ID")
+      "Message ID"
   , Option
       []
       ["type"]
       (ReqArg (\s o -> o {msgtype = Just $ pack s}) "TYPE")
-      ("Message Type")
+      "Message Type"
   , Option
       []
       ["userid"]
       (ReqArg (\s o -> o {userid = Just $ pack s}) "USERID")
-      ("Message User-ID")
+      "Message User-ID"
   , Option
       []
       ["appid"]
       (ReqArg (\s o -> o {appid = Just $ pack s}) "APPID")
-      ("Message App-ID")
+      "Message App-ID"
   , Option
       []
       ["clusterid"]
       (ReqArg (\s o -> o {clusterid = Just $ pack s}) "CLUSTERID")
-      ("Message Cluster-ID")
+      "Message Cluster-ID"
   , Option
       []
       ["contenttype"]
       (ReqArg (\s o -> o {contenttype = Just $ pack s}) "CONTENTTYPE")
-      ("Message Content-Type")
+      "Message Content-Type"
   , Option
       []
       ["contentencoding"]
-      (ReqArg
-         (\s o -> o {contentencoding = Just $ pack s})
-         "CONTENTENCODING")
-      ("Message Content-Encoding")
+      (ReqArg (\s o -> o {contentencoding = Just $ pack s}) "CONTENTENCODING")
+      "Message Content-Encoding"
   , Option
       []
       ["replyto"]
       (ReqArg (\s o -> o {replyto = Just $ pack s}) "REPLYTO")
-      ("Message Reply-To")
+      "Message Reply-To"
   , Option
       []
       ["prio"]
       (ReqArg (\s o -> o {prio = Just $ read s}) "PRIO")
-      ("Message Priority")
+      "Message Priority"
   , Option
       []
       ["corrid"]
       (ReqArg (\s o -> o {corrid = Just $ pack s}) "CORRID")
-      ("Message CorrelationID")
+      "Message CorrelationID"
   , Option
       []
       ["exp"]
       (ReqArg (\s o -> o {msgexp = Just $ pack s}) "EXP")
-      ("Message Expiration")
+      "Message Expiration"
   , Option
       ['h']
       ["header"]
       (ReqArg (\s o -> o {msgheader = addheader (msgheader o) s}) "HEADER=VALUE")
-      ("Message Headers")
+      "Message Headers"
   , Option
       ['F']
       ["fnheader"]
-      (ReqArg (\s o -> o {fnheader = s:(fnheader o)}) "HEADERNAME")
-      ("Put filename into this header")
+      (ReqArg (\s o -> o {fnheader = s : (fnheader o)}) "HEADERNAME")
+      "Put filename into this header"
   , Option
       ['S']
       ["suffix"]
-      (ReqArg (\s o -> o {suffix = s:(suffix o)}) "SUFFIX")
-      ("Allowed file suffixes in hotfolder mode")
+      (ReqArg (\s o -> o {suffix = s : (suffix o)}) "SUFFIX")
+      "Allowed file suffixes in hotfolder mode"
+  , Option
+      ['m']
+      ["magic"]
+      (NoArg (\o -> o {magic = not (magic o)}))
+      "Toggle setting content-type and content-encoding from file contents"
   ]
 
 -- | Options for the executables
@@ -315,10 +320,10 @@ addheader (Just (FieldTable oldheader)) string =
   Just $ FieldTable $ M.insert (k string) (v string) oldheader
 
 k :: String -> Text
-k s = pack $ takeWhile (/='=') s
+k s = pack $ takeWhile (/= '=') s
 
 v :: String -> FieldValue
-v s = FVString $ pack $ tail $ dropWhile (/='=') s
+v s = FVString $ pack $ tail $ dropWhile (/= '=') s
 
 -- | 'parseargs' exename argstring
 -- applies options onto argstring

diff --git a/agitprop.hs b/agitprop.hs
index fd4922d298b621a7094b9e95db20168f8febe555..88ed85ec6cad7e05bf109a1a9ab04233cf9328c4 100644 (file)
--- a/agitprop.hs
+++ b/agitprop.hs
@@ -4,12 +4,14 @@ import Control.Concurrent (threadDelay)
 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.List (isSuffixOf)
+import Data.Maybe
+import qualified Data.Text as T
 import Data.Time
 import Data.Time.Clock.POSIX
 import Data.Version (showVersion)
 import Data.Word (Word64)
+import Magic
 import Network.AMQP
 import Network.AMQP.Types
 import Network.AMQP.Utils.Connection
@@ -80,16 +82,21 @@ confirmCallback (deliveryTag, isAll, ackType) =
      (show ackType))
 
 -- | Hotfolder event handler
-handleEvent :: (Maybe String -> BL.ByteString -> IO ()) -> [ String ] -> Event -> IO ()
+handleEvent ::
+     (Maybe String -> BL.ByteString -> IO ()) -> [String] -> Event -> IO ()
 -- just handle closewrite and movedin events
 handleEvent f s (Closed False (Just x) True) = handleFile f s x
 handleEvent f s (MovedIn False x _) = handleFile f s x
 handleEvent _ _ _ = return ()
 
 -- | Hotfolder file handler
-handleFile :: (Maybe String -> BL.ByteString -> IO ()) -> [String] -> FilePath -> IO ()
+handleFile ::
+     (Maybe String -> BL.ByteString -> IO ()) -> [String] -> FilePath -> IO ()
 handleFile _ _ ('.':_) = return () -- ignore hidden files
-handleFile f s@(_:_) x = if any (flip isSuffixOf x) s then handleFile f [] x else return ()
+handleFile f s@(_:_) x =
+  if any (flip isSuffixOf x) s
+    then handleFile f [] x
+    else return ()
 handleFile f [] x =
   X.catch
     (hr ("sending " ++ x) >> BL.readFile x >>= f (Just x))
@@ -100,6 +107,16 @@ handleFile f [] x =
 -- | Publish one message with our settings
 publishOneMsg' :: Channel -> Args -> Maybe String -> BL.ByteString -> IO ()
 publishOneMsg' c a fn f = do
+  (mtype, mencoding) <-
+    if (magic a) && isJust fn
+      then do
+        m <- magicOpen [MagicMimeType]
+        magicLoadDefault m
+        t <- magicFile m (fromJust fn)
+        magicSetFlags m [MagicMimeEncoding]
+        e <- magicFile m (fromJust fn)
+        return (Just (T.pack t), Just (T.pack e))
+      else return ((contenttype a), (contentencoding a))
   now <- getCurrentTime >>= return . floor . utcTimeToPOSIXSeconds
   r <-
     publishMsg
@@ -115,8 +132,8 @@ publishOneMsg' c a fn f = do
         , msgUserID = userid a
         , msgApplicationID = appid a
         , msgClusterID = clusterid a
-        , msgContentType = contenttype a
-        , msgContentEncoding = contentencoding a
+        , msgContentType = mtype
+        , msgContentEncoding = mencoding
         , msgReplyTo = replyto a
         , msgPriority = prio a
         , msgCorrelationID = corrid a
@@ -125,7 +142,8 @@ publishOneMsg' c a fn f = do
         }
   printparam "sent" $ fmap show r
   where
-    substheader :: [String] -> Maybe String -> Maybe FieldTable -> Maybe FieldTable
+    substheader ::
+         [String] -> Maybe String -> Maybe FieldTable -> Maybe FieldTable
     substheader (s:r) (Just fname) old =
       substheader r (Just fname) (addheader old (s ++ "=" ++ fname))
     substheader _ _ old = old

diff --git a/amqp-utils.cabal b/amqp-utils.cabal
index 4445bf5d7ad883a9e10e38468004c8b42c8affa1..4c8d586af8927d4cc3fb897f2591c0d611e91267 100644 (file)
--- a/amqp-utils.cabal
+++ b/amqp-utils.cabal
@@ -66,7 +66,8 @@ executable agitprop
                        tls,
                        amqp >=0.17,
                        unix >= 2.7,
-                       hinotify >= 0.3.8 && < 0.3.10
+                       hinotify >= 0.3.8 && < 0.3.10,
+                       magic
   
   ghc-options:         -threaded -Wall
   

diff --git a/amqp-utils.nix b/amqp-utils.nix
index 9ee73e4325540ec76b5f5192ecdb3aba39c6f142..b3fa3899790400c08e1ecba24f4e69de505b3a57 100644 (file)
--- a/amqp-utils.nix
+++ b/amqp-utils.nix
@@ -1,6 +1,6 @@
 { mkDerivation, amqp, base, bytestring, connection, containers
 , data-default-class, process, stdenv, text, time, tls, x509-system
-, unix, hinotify
+, unix, hinotify, magic
 }:
 mkDerivation {
   pname = "amqp-utils";
@@ -11,7 +11,7 @@ mkDerivation {
   enableSharedExecutables = false;
   executableHaskellDepends = [
     amqp base bytestring connection containers data-default-class
-    process text time tls x509-system unix hinotify
+    process text time tls x509-system unix hinotify magic
   ];
   description = "Generic Haskell AMQP Consumer";
   license = stdenv.lib.licenses.gpl3;