agitprop: automatic timestamp

diff --git a/Network/AMQP/Utils/Helpers.hs b/Network/AMQP/Utils/Helpers.hs
index 74553a0147a8bffd80b654eea8effe0c046e3b12..8845f1e18f612cf8247cc27c913741c39ffcf798 100644 (file)
--- a/Network/AMQP/Utils/Helpers.hs
+++ b/Network/AMQP/Utils/Helpers.hs
@@ -1,7 +1,16 @@
 module Network.AMQP.Utils.Helpers where
 
 import qualified Data.ByteString.Lazy.Char8 as BL
+import qualified Data.Map as M
+import qualified Data.Text as T
+import Data.Time
+import Data.Time.Clock.POSIX
+import Network.AMQP
+import Network.AMQP.Types
 import System.IO
+import Data.Maybe
+import Data.List
+import Control.Monad
 
 -- | log cmdline options
 listToMaybeUnwords :: [String] -> Maybe String
@@ -35,3 +44,142 @@ hr x = putStrLn hr' >> hFlush stdout
   where
     hr' = take 72 $ (take 25 hr'') ++ " " ++ x ++ " " ++ hr''
     hr'' = repeat '-'
+
+formatheaders :: ((T.Text, FieldValue) -> [a]) -> FieldTable -> [a]
+formatheaders f (FieldTable ll) = concat $ map f $ M.toList ll
+
+-- | log formatting
+fieldshow :: (T.Text, FieldValue) -> String
+fieldshow (k, v) = "\n        " ++ T.unpack k ++ ": " ++ valueshow v
+
+-- | callback cmdline formatting
+fieldshow' :: (T.Text, FieldValue) -> [String]
+fieldshow' (k, v) = ["-h", T.unpack k ++ "=" ++ valueshow v]
+
+-- | showing a FieldValue
+valueshow :: FieldValue -> String
+valueshow (FVString value) = T.unpack value
+valueshow (FVInt32 value) = show value
+valueshow value = show value
+
+-- | skip showing body head if binary type
+isimage :: Maybe String -> Bool
+isimage Nothing = False
+isimage (Just ctype)
+  | isPrefixOf "application/xml" ctype = False
+  | isPrefixOf "application/json" ctype = False
+  | otherwise = any (flip isPrefixOf ctype) ["application", "image"]
+
+-- | show the first bytes of message body
+anriss' :: Maybe Int -> BL.ByteString -> BL.ByteString
+anriss' x =
+  case x of
+    Nothing -> id
+    Just y -> BL.take (fromIntegral y)
+
+-- | callback cmdline with optional parameters
+printopt :: (String, Maybe String) -> [String]
+printopt (_, Nothing) = []
+printopt (opt, Just s) = [opt, s]
+
+-- | prints header and head on STDOUT and returns cmdline options to callback
+printmsg :: (Message, Envelope) -> Maybe Int -> ZonedTime -> IO [String]
+printmsg (msg, envi) anR now = do
+  mapM_
+    (uncurry printparam)
+    [ ("routing key", rkey)
+    , ("message-id", messageid)
+    , ("headers", headers)
+    , ("content-type", contenttype)
+    , ("content-encoding", contentencoding)
+    , ("redelivered", redeliv)
+    , ("timestamp", timestamp'')
+    , ("time now", now')
+    , ("size", size)
+    , ("priority", prio)
+    , ("type", mtype)
+    , ("user id", muserid)
+    , ("application id", mappid)
+    , ("cluster id", mclusterid)
+    , ("reply to", mreplyto)
+    , ("correlation id", mcorrid)
+    , ("expiration", mexp)
+    , ("delivery mode", mdelivmode)
+    ]
+  printbody (label, anriss)
+  return $
+    concat
+      (map
+         printopt
+         [ ("-r", rkey)
+         , ("-m", contenttype)
+         , ("-e", contentencoding)
+         , ("-i", messageid)
+         , ("-t", timestamp)
+         , ("-p", prio)
+         ] ++
+       maybeToList headers')
+  where
+    headers = fmap (formatheaders fieldshow) $ msgHeaders msg
+    headers' = fmap (formatheaders fieldshow') $ msgHeaders msg
+    body = msgBody msg
+    anriss =
+      if isimage contenttype
+        then Nothing
+        else Just (anriss' anR body) :: Maybe BL.ByteString
+    anriss'' = maybe "" (\a -> "first " ++ (show a) ++ " bytes of ") anR
+    label = anriss'' ++ "body"
+    contenttype = fmap T.unpack $ msgContentType msg
+    contentencoding = fmap T.unpack $ msgContentEncoding msg
+    rkey = Just . T.unpack $ envRoutingKey envi
+    messageid = fmap T.unpack $ msgID msg
+    prio = fmap show $ msgPriority msg
+    mtype = fmap show $ msgType msg
+    muserid = fmap show $ msgUserID msg
+    mappid = fmap show $ msgApplicationID msg
+    mclusterid = fmap show $ msgClusterID msg
+    mreplyto = fmap show $ msgReplyTo msg
+    mcorrid = fmap show $ msgCorrelationID msg
+    mexp = fmap show $ msgExpiration msg
+    mdelivmode = fmap show $ msgDeliveryMode msg
+    size = Just . show $ BL.length body
+    redeliv =
+      if envRedelivered envi
+        then Just "YES"
+        else Nothing
+    tz = zonedTimeZone now
+    nowutc = zonedTimeToUTCFLoor now
+    msgtime = msgTimestamp msg
+    msgtimeutc = fmap (posixSecondsToUTCTime . realToFrac) msgtime
+    timestamp = fmap show msgtime
+    timediff = fmap (difftime nowutc) msgtimeutc
+    now' =
+      case timediff of
+        Just "now" -> Nothing
+        _ -> showtime tz $ Just nowutc
+    timestamp' = showtime tz msgtimeutc
+    timestamp'' =
+      liftM3
+        (\a b c -> a ++ " (" ++ b ++ ") (" ++ c ++ ")")
+        timestamp
+        timestamp'
+        timediff
+
+-- | timestamp conversion
+zonedTimeToUTCFLoor :: ZonedTime -> UTCTime
+zonedTimeToUTCFLoor x =
+  posixSecondsToUTCTime $
+  realToFrac ((floor . utcTimeToPOSIXSeconds . zonedTimeToUTC) x :: Timestamp)
+
+-- | show the timestamp
+showtime :: TimeZone -> Maybe UTCTime -> Maybe String
+showtime tz = fmap (show . (utcToZonedTime tz))
+
+-- | show difference between two timestamps
+difftime :: UTCTime -> UTCTime -> String
+difftime now msg
+  | now == msg = "now"
+  | now > msg = diff ++ " ago"
+  | otherwise = diff ++ " in the future"
+  where
+    diff = show (diffUTCTime now msg)

diff --git a/agitprop.hs b/agitprop.hs
index 2a1529130fd289a6a5307deee6dc80c3f52473a3..c14f68b37350fcc4ce2d740e9e8cbb7d69620c8a 100644 (file)
--- a/agitprop.hs
+++ b/agitprop.hs
@@ -15,6 +15,8 @@ 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
@@ -95,6 +97,7 @@ handleFile f x =
 -- | Publish one message with our settings
 publishOneMsg' :: Channel -> Args -> BL.ByteString -> IO ()
 publishOneMsg' c a f = do
+      now <- getCurrentTime >>= return.utcTimeToPOSIXSeconds >>= return.floor
       r <-
         publishMsg
           c
@@ -102,7 +105,7 @@ publishOneMsg' c a f = do
           (T.pack $ rKey a)
           newMsg { msgBody = f
                  , msgDeliveryMode = Just Persistent
-                 , msgTimestamp = msgtimestamp a
+                 , msgTimestamp = Just now
                  , msgID = msgid a
                  , msgType = msgtype a
                  , msgUserID = msguserid a

diff --git a/konsum.hs b/konsum.hs
index 6a0e306b757e31d18b1c28ba7a2ad6ad586ecd11..5f98636e2ba4bf1daff161ac5e2f718a44e4e45f 100644 (file)
--- a/konsum.hs
+++ b/konsum.hs
@@ -19,15 +19,10 @@ import Control.Concurrent
 import qualified Control.Exception as X
 import Control.Monad
 import qualified Data.ByteString.Lazy.Char8 as BL
-import Data.List
-import qualified Data.Map as M
-import Data.Maybe
 import qualified Data.Text as T
 import Data.Time
-import Data.Time.Clock.POSIX
 import Data.Version (showVersion)
 import Network.AMQP
-import Network.AMQP.Types
 import Network.AMQP.Utils.Connection
 import Network.AMQP.Utils.Helpers
 import Network.AMQP.Utils.Options
@@ -166,142 +161,3 @@ doProc numstring envi (exe:args) = do
     ExitSuccess -> ackEnv envi
     ExitFailure _ -> rejectEnv envi True
 doProc _ _ _ = return ()
-
-formatheaders :: ((T.Text, FieldValue) -> [a]) -> FieldTable -> [a]
-formatheaders f (FieldTable ll) = concat $ map f $ M.toList ll
-
--- | log formatting
-fieldshow :: (T.Text, FieldValue) -> String
-fieldshow (k, v) = "\n        " ++ T.unpack k ++ ": " ++ valueshow v
-
--- | callback cmdline formatting
-fieldshow' :: (T.Text, FieldValue) -> [String]
-fieldshow' (k, v) = ["-h", T.unpack k ++ "=" ++ valueshow v]
-
--- | showing a FieldValue
-valueshow :: FieldValue -> String
-valueshow (FVString value) = T.unpack value
-valueshow (FVInt32 value) = show value
-valueshow value = show value
-
--- | skip showing body head if binary type
-isimage :: Maybe String -> Bool
-isimage Nothing = False
-isimage (Just ctype)
-  | isPrefixOf "application/xml" ctype = False
-  | isPrefixOf "application/json" ctype = False
-  | otherwise = any (flip isPrefixOf ctype) ["application", "image"]
-
--- | show the first bytes of message body
-anriss' :: Maybe Int -> BL.ByteString -> BL.ByteString
-anriss' x =
-  case x of
-    Nothing -> id
-    Just y -> BL.take (fromIntegral y)
-
--- | callback cmdline with optional parameters
-printopt :: (String, Maybe String) -> [String]
-printopt (_, Nothing) = []
-printopt (opt, Just s) = [opt, s]
-
--- | prints header and head on STDOUT and returns cmdline options to callback
-printmsg :: (Message, Envelope) -> Maybe Int -> ZonedTime -> IO [String]
-printmsg (msg, envi) anR now = do
-  mapM_
-    (uncurry printparam)
-    [ ("routing key", rkey)
-    , ("message-id", messageid)
-    , ("headers", headers)
-    , ("content-type", contenttype)
-    , ("content-encoding", contentencoding)
-    , ("redelivered", redeliv)
-    , ("timestamp", timestamp'')
-    , ("time now", now')
-    , ("size", size)
-    , ("priority", prio)
-    , ("type", mtype)
-    , ("user id", muserid)
-    , ("application id", mappid)
-    , ("cluster id", mclusterid)
-    , ("reply to", mreplyto)
-    , ("correlation id", mcorrid)
-    , ("expiration", mexp)
-    , ("delivery mode", mdelivmode)
-    ]
-  printbody (label, anriss)
-  return $
-    concat
-      (map
-         printopt
-         [ ("-r", rkey)
-         , ("-m", contenttype)
-         , ("-e", contentencoding)
-         , ("-i", messageid)
-         , ("-t", timestamp)
-         , ("-p", prio)
-         ] ++
-       maybeToList headers')
-  where
-    headers = fmap (formatheaders fieldshow) $ msgHeaders msg
-    headers' = fmap (formatheaders fieldshow') $ msgHeaders msg
-    body = msgBody msg
-    anriss =
-      if isimage contenttype
-        then Nothing
-        else Just (anriss' anR body) :: Maybe BL.ByteString
-    anriss'' = maybe "" (\a -> "first " ++ (show a) ++ " bytes of ") anR
-    label = anriss'' ++ "body"
-    contenttype = fmap T.unpack $ msgContentType msg
-    contentencoding = fmap T.unpack $ msgContentEncoding msg
-    rkey = Just . T.unpack $ envRoutingKey envi
-    messageid = fmap T.unpack $ msgID msg
-    prio = fmap show $ msgPriority msg
-    mtype = fmap show $ msgType msg
-    muserid = fmap show $ msgUserID msg
-    mappid = fmap show $ msgApplicationID msg
-    mclusterid = fmap show $ msgClusterID msg
-    mreplyto = fmap show $ msgReplyTo msg
-    mcorrid = fmap show $ msgCorrelationID msg
-    mexp = fmap show $ msgExpiration msg
-    mdelivmode = fmap show $ msgDeliveryMode msg
-    size = Just . show $ BL.length body
-    redeliv =
-      if envRedelivered envi
-        then Just "YES"
-        else Nothing
-    tz = zonedTimeZone now
-    nowutc = zonedTimeToUTCFLoor now
-    msgtime = msgTimestamp msg
-    msgtimeutc = fmap (posixSecondsToUTCTime . realToFrac) msgtime
-    timestamp = fmap show msgtime
-    timediff = fmap (difftime nowutc) msgtimeutc
-    now' =
-      case timediff of
-        Just "now" -> Nothing
-        _ -> showtime tz $ Just nowutc
-    timestamp' = showtime tz msgtimeutc
-    timestamp'' =
-      liftM3
-        (\a b c -> a ++ " (" ++ b ++ ") (" ++ c ++ ")")
-        timestamp
-        timestamp'
-        timediff
-
--- | timestamp conversion
-zonedTimeToUTCFLoor :: ZonedTime -> UTCTime
-zonedTimeToUTCFLoor x =
-  posixSecondsToUTCTime $
-  realToFrac ((floor . utcTimeToPOSIXSeconds . zonedTimeToUTC) x :: Timestamp)
-
--- | show the timestamp
-showtime :: TimeZone -> Maybe UTCTime -> Maybe String
-showtime tz = fmap (show . (utcToZonedTime tz))
-
--- | show difference between two timestamps
-difftime :: UTCTime -> UTCTime -> String
-difftime now msg
-  | now == msg = "now"
-  | now > msg = diff ++ " ago"
-  | otherwise = diff ++ " in the future"
-  where
-    diff = show (diffUTCTime now msg)