Helpers.hs

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
listToMaybeUnwords [] = Nothing
listToMaybeUnwords x = Just $ unwords x

-- | Strings or ByteStrings with label, oder nothing at all
printwithlabel :: String -> Maybe (IO ()) -> IO ()
printwithlabel _ Nothing = return ()
printwithlabel labl (Just i) = do
  mapM_ putStr [" --- ", labl, ": "]
  i
  hFlush stdout

-- | optional parameters
printparam :: String -> Maybe String -> IO ()
printparam labl ms = printwithlabel labl $ fmap putStrLn ms

-- | required parameters
printparam' :: String -> String -> IO ()
printparam' d s = printparam d (Just s)

-- | head chars of body
printbody :: (String, Maybe BL.ByteString) -> IO ()
printbody (labl, ms) =
  printwithlabel labl $ fmap (\s -> putStrLn "" >> BL.putStrLn s) ms

-- | log marker
hr :: String -> IO ()
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)