Network/AMQP/Utils/Helpers.hs

   1 -- SPDX-FileCopyrightText: 2022 Frank Doepper
   2 --
   3 -- SPDX-License-Identifier: GPL-3.0-only
   4
   5 {-# LANGUAGE FlexibleInstances #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7
   8 module Network.AMQP.Utils.Helpers where
   9
  10 import           Control.Concurrent
  11 import qualified Control.Exception                as X
  12 import           Control.Monad
  13 import qualified Data.ByteString.Char8            as BS
  14 import qualified Data.ByteString.Lazy.Char8       as BL
  15 import qualified Data.ByteString.UTF8             as BU
  16 import           Data.Int                         (Int64)
  17 import           Data.List
  18 import qualified Data.Map                         as M
  19 import           Data.Maybe
  20 import qualified Data.Text                        as T
  21 import           Data.Time
  22 import           Data.Time.Clock.POSIX
  23 import           Data.Word                        (Word16)
  24 import           Network.AMQP
  25 import           Network.AMQP.Types
  26 import           Network.AMQP.Utils.Options
  27 import           Network.Socket                   (PortNumber)
  28 import           System.Directory                 (removeFile)
  29 import           System.Environment               (getEnvironment)
  30 import           System.Exit
  31 import           System.FilePath.Posix.ByteString (RawFilePath)
  32 import           System.IO
  33 import           System.Posix.IO.ByteString
  34 import           System.Process
  35
  36 -- | print config parameters
  37 class (Show a) =>
  38       Flexprint a
  39   where
  40   flexprint :: a -> IO ()
  41   flexprint = (hPutStrLn stderr) . show
  42   empty :: a -> Bool
  43   empty _ = False
  44   printparam :: String -> a -> IO ()
  45   printparam label x =
  46     if empty x
  47       then return ()
  48       else do
  49         mapM_ (hPutStr stderr) [" --- ", label, ": "]
  50         flexprint x
  51         hFlush stderr
  52
  53 instance (Flexprint a) => Flexprint (Maybe a) where
  54   empty = isNothing
  55   printparam _ Nothing  = return ()
  56   printparam x (Just y) = printparam x y
  57
  58 instance Flexprint BS.ByteString where
  59   flexprint = BS.hPutStrLn stderr
  60   empty = BS.null
  61
  62 instance Flexprint String where
  63   flexprint = hPutStrLn stderr
  64   empty = null
  65
  66 instance Flexprint [BS.ByteString] where
  67   flexprint = flexprint . BS.unwords
  68   empty = null
  69
  70 instance Flexprint [String] where
  71   flexprint = flexprint . unwords
  72   empty = null
  73
  74 instance Flexprint [Maybe BS.ByteString] where
  75   flexprint = flexprint . catMaybes
  76   empty = null . catMaybes
  77
  78 instance Flexprint [Maybe String] where
  79   flexprint = flexprint . catMaybes
  80   empty = null . catMaybes
  81
  82 instance Flexprint T.Text where
  83   flexprint = flexprint . T.unpack
  84   empty = T.null
  85
  86 instance Flexprint BL.ByteString where
  87   flexprint x = hPutStrLn stderr "" >> BL.hPut stderr x >> hPutStrLn stderr ""
  88   empty = BL.null
  89
  90 instance Flexprint Bool where
  91   empty = not
  92
  93 instance Flexprint Int
  94
  95 instance Flexprint Int64
  96
  97 instance Flexprint Word16
  98
  99 instance Flexprint ExitCode
 100
 101 instance Flexprint X.SomeException
 102
 103 instance Flexprint X.IOException
 104
 105 instance Flexprint AMQPException
 106
 107 instance Flexprint ConfirmationResult
 108
 109 instance Flexprint PortNumber
 110
 111 -- | log marker
 112 hr :: String -> IO ()
 113 hr x = hPutStrLn stderr hr' >> hFlush stderr
 114   where
 115     hr' = take 72 $ (take 25 hr'') ++ " " ++ x ++ " " ++ hr''
 116     hr'' = repeat '-'
 117
 118 -- | format headers for printing
 119 formatheaders :: ((T.Text, FieldValue) -> [a]) -> FieldTable -> [a]
 120 formatheaders f (FieldTable ll) = concat $ map f $ M.toList ll
 121
 122 -- | format headers for setting environment variables
 123 formatheadersEnv ::
 124      ((Int, (T.Text, FieldValue)) -> [(String, String)])
 125   -> FieldTable
 126   -> [(String, String)]
 127 formatheadersEnv f (FieldTable ll) = concat $ map f $ zip [0 ..] $ M.toList ll
 128
 129 -- | log formatting
 130 fieldshow :: (T.Text, FieldValue) -> String
 131 fieldshow (k, v) = "\n        " ++ T.unpack k ++ ": " ++ valueshow v
 132
 133 fieldshow' :: (T.Text, FieldValue) -> String
 134 fieldshow' (k, v) = "\n           " ++ T.unpack k ++ ": " ++ valueshow v
 135
 136 -- | callback cmdline formatting
 137 fieldshowOpt :: (T.Text, FieldValue) -> [String]
 138 fieldshowOpt (k, v) = ["-h", T.unpack k ++ "=" ++ valueshow v]
 139
 140 -- | environment variable formatting
 141 fieldshowEnv :: (Int, (T.Text, FieldValue)) -> [(String, String)]
 142 fieldshowEnv (n, (k, v)) =
 143   [ ("AMQP_HEADER_KEY_" ++ nn, T.unpack k)
 144   , ("AMQP_HEADER_VALUE_" ++ nn, valueshow v)
 145   ]
 146   where
 147     nn = show n
 148
 149 -- | showing a FieldValue
 150 valueshow :: FieldValue -> String
 151 valueshow (FVString value)     = BU.toString value
 152 valueshow (FVInt8 value)       = show value
 153 valueshow (FVInt16 value)      = show value
 154 valueshow (FVInt32 value)      = show value
 155 valueshow (FVInt64 value)      = show value
 156 valueshow (FVFloat value)      = show value
 157 valueshow (FVDouble value)     = show value
 158 valueshow (FVBool value)       = show value
 159 valueshow (FVFieldTable value) = (formatheaders fieldshow') value
 160 valueshow value                = show value
 161
 162 -- | skip showing body head if binary type
 163 isimage :: Maybe String -> Bool
 164 isimage Nothing = False
 165 isimage (Just ctype)
 166   | isPrefixOf "application/xml" ctype = False
 167   | isPrefixOf "application/json" ctype = False
 168   | otherwise = any (flip isPrefixOf ctype) ["application", "image"]
 169
 170 -- | show the first bytes of message body
 171 anriss' :: Maybe Int64 -> BL.ByteString -> BL.ByteString
 172 anriss' x =
 173   case x of
 174     Nothing -> id
 175     Just y  -> BL.take y
 176
 177 -- | callback cmdline with optional parameters
 178 printopt :: (String, Maybe String) -> [String]
 179 printopt (_, Nothing)  = []
 180 printopt (opt, Just s) = [opt, s]
 181
 182 -- | prints header and head on stderr and returns
 183 -- cmdline options and environment variables to callback
 184 printmsg ::
 185      Maybe Handle
 186   -> (Message, Envelope)
 187   -> Maybe Int64
 188   -> ZonedTime
 189   -> IO ([String], [(String, String)])
 190 printmsg h (msg, envi) anR now = do
 191   mapM_
 192     (uncurry printparam)
 193     [ ("routing key", rkey)
 194     , ("message-id", messageid)
 195     , ("headers", headers)
 196     , ("content-type", ctype)
 197     , ("content-encoding", cenc)
 198     , ("redelivered", redeliv)
 199     , ("timestamp", timestamp'')
 200     , ("time now", now')
 201     , ("size", size)
 202     , ("priority", pri)
 203     , ("type", mtype)
 204     , ("user id", muserid)
 205     , ("application id", mappid)
 206     , ("cluster id", mclusterid)
 207     , ("reply to", mreplyto)
 208     , ("correlation id", mcorrid)
 209     , ("expiration", mexp)
 210     , ("delivery mode", mdelivmode)
 211     ]
 212   printparam label anriss
 213   mapM_ (\hdl -> BL.hPut hdl body >> hFlush hdl) h
 214   oldenv <- getEnvironment
 215   let environment =
 216         foldr
 217           step
 218           oldenv
 219           [ ("ROUTINGKEY", rkey)
 220           , ("CONTENTTYPE", ctype)
 221           , ("ENCODING", cenc)
 222           , ("MSGID", messageid)
 223           , ("TIMESTAMP", timestamp)
 224           , ("PRIORITY", pri)
 225           , ("REDELIVERED", redeliv)
 226           , ("SIZE", size)
 227           , ("TYPE", mtype)
 228           , ("USERID", muserid)
 229           , ("APPID", mappid)
 230           , ("CLUSTERID", mclusterid)
 231           , ("REPLYTO", mreplyto)
 232           , ("CORRID", mcorrid)
 233           , ("EXPIRATION", mexp)
 234           , ("DELIVERYMODE", mdelivmode)
 235           ] ++
 236         headersEnv
 237   return (cmdline, environment)
 238   where
 239     step (_, Nothing) xs = xs
 240     step (k, Just v) xs  = ("AMQP_" ++ k, v) : xs
 241     cmdline =
 242       concat
 243         (map
 244            printopt
 245            [ ("-r", rkey)
 246            , ("-m", ctype)
 247            , ("-e", cenc)
 248            , ("-i", messageid)
 249            , ("-t", timestamp)
 250            , ("-p", pri)
 251            , ("-R", redeliv)
 252            ] ++
 253          headersOpt)
 254     headers = fmap (formatheaders fieldshow) $ msgHeaders msg
 255     headersOpt =
 256       maybeToList $ fmap (formatheaders fieldshowOpt) $ msgHeaders msg
 257     headersEnv =
 258       concat . maybeToList $
 259       fmap (formatheadersEnv fieldshowEnv) $ msgHeaders msg
 260     body = msgBody msg
 261     anriss =
 262       if isimage ctype
 263         then Nothing
 264         else Just (anriss' anR body) :: Maybe BL.ByteString
 265     anriss'' = maybe "" (\a -> "first " ++ (show a) ++ " bytes of ") anR
 266     label = anriss'' ++ "body"
 267     ctype = fmap T.unpack $ msgContentType msg
 268     cenc = fmap T.unpack $ msgContentEncoding msg
 269     rkey = Just . T.unpack $ envRoutingKey envi
 270     messageid = fmap T.unpack $ msgID msg
 271     pri = fmap show $ msgPriority msg
 272     mtype = fmap T.unpack $ msgType msg
 273     muserid = fmap T.unpack $ msgUserID msg
 274     mappid = fmap T.unpack $ msgApplicationID msg
 275     mclusterid = fmap T.unpack $ msgClusterID msg
 276     mreplyto = fmap T.unpack $ msgReplyTo msg
 277     mcorrid = fmap T.unpack $ msgCorrelationID msg
 278     mexp = fmap T.unpack $ msgExpiration msg
 279     mdelivmode = fmap show $ msgDeliveryMode msg
 280     size = Just . show $ BL.length body
 281     redeliv =
 282       if envRedelivered envi
 283         then Just "YES"
 284         else Nothing
 285     tz = zonedTimeZone now
 286     nowutc = zonedTimeToUTCFLoor now
 287     msgtime = msgTimestamp msg
 288     msgtimeutc = fmap (posixSecondsToUTCTime . realToFrac) msgtime
 289     timestamp = fmap show msgtime
 290     timediff = fmap (difftime nowutc) msgtimeutc
 291     now' =
 292       case timediff of
 293         Just "now" -> Nothing
 294         _          -> showtime tz $ Just nowutc
 295     timestamp' = showtime tz msgtimeutc
 296     timestamp'' =
 297       liftM3
 298         (\a b c -> a ++ " (" ++ b ++ ") (" ++ c ++ ")")
 299         timestamp
 300         timestamp'
 301         timediff
 302
 303 -- | timestamp conversion
 304 zonedTimeToUTCFLoor :: ZonedTime -> UTCTime
 305 zonedTimeToUTCFLoor x =
 306   posixSecondsToUTCTime $
 307   realToFrac ((floor . utcTimeToPOSIXSeconds . zonedTimeToUTC) x :: Timestamp)
 308
 309 -- | show the timestamp
 310 showtime :: TimeZone -> Maybe UTCTime -> Maybe String
 311 showtime tz = fmap (show . (utcToZonedTime tz))
 312
 313 -- | show difference between two timestamps
 314 difftime :: UTCTime -> UTCTime -> String
 315 difftime now msg
 316   | now == msg = "now"
 317   | now > msg = diff ++ " ago"
 318   | otherwise = diff ++ " in the future"
 319   where
 320     diff = show (diffUTCTime now msg)
 321
 322 -- | if the message is to be saved
 323 -- and maybe processed further
 324 optionalFileStuff ::
 325      (Message, Envelope)
 326   -> [String]
 327   -> [String]
 328   -> String
 329   -> Args
 330   -> ThreadId
 331   -> Maybe (ExitCode -> BL.ByteString -> IO ())
 332   -> [(String, String)]
 333   -> IO ()
 334 optionalFileStuff (msg, envi) callbackoptions addi numstring a tid action environment = do
 335   path <- saveFile (tempDir a) numstring (msgBody msg)
 336   printparam "saved to" path
 337   let callbackcmdline =
 338         liftM2
 339           (constructCallbackCmdLine (simple a) callbackoptions addi numstring)
 340           (fileProcess a)
 341           path
 342   printparam "calling" callbackcmdline
 343   maybe
 344     (acke envi a)
 345     (\c ->
 346        forkFinally
 347          (doProc a numstring envi c action path environment)
 348          (either (throwTo tid) return) >>
 349        return ())
 350     callbackcmdline
 351
 352 -- | save message into temp file
 353 saveFile :: Maybe String -> String -> BL.ByteString -> IO (Maybe String)
 354 saveFile Nothing _ _ = return Nothing
 355 saveFile (Just tempD) numstring body = do
 356   (p, h) <-
 357     openBinaryTempFileWithDefaultPermissions
 358       tempD
 359       ("amqp-utils-" ++ numstring ++ "-.tmp")
 360   BL.hPut h body
 361   hClose h
 362   return $ Just p
 363
 364 -- | construct cmdline for callback script
 365 constructCallbackCmdLine ::
 366      Bool -> [String] -> [String] -> String -> String -> String -> [String]
 367 constructCallbackCmdLine True _ addi _ exe path = exe : addi ++ path : []
 368 constructCallbackCmdLine False opts addi num exe path =
 369   exe : "-f" : path : "-n" : num : opts ++ addi
 370
 371 -- | call callback script
 372 doProc ::
 373      Args
 374   -> String
 375   -> Envelope
 376   -> [String]
 377   -> Maybe (ExitCode -> BL.ByteString -> IO ())
 378   -> Maybe String
 379   -> [(String, String)]
 380   -> IO ()
 381 doProc a numstring envi (exe:args) action path environment = do
 382   (_, h, _, processhandle) <-
 383     createProcess
 384       (proc exe args)
 385         {std_out = out, std_err = Inherit, env = Just environment'}
 386   sout <- mapM BL.hGetContents h
 387   exitcode <-
 388     maybe 0 id (fmap BL.length sout) `seq` waitForProcess processhandle
 389   printparam (numstring ++ " call returned") exitcode
 390   if isJust action && isJust sout
 391     then ((fromJust action $ exitcode) (fromJust sout)) >> acke envi a
 392     else case exitcode of
 393            ExitSuccess   -> acke envi a
 394            ExitFailure _ -> reje envi a
 395   if (cleanupTmpFile a)
 396     then X.catch
 397            (maybe (return ()) removeFile path)
 398            (\e -> printparam "error removing temp file" (e :: X.IOException))
 399     else return ()
 400   where
 401     out =
 402       if isJust action
 403         then CreatePipe
 404         else Inherit
 405     environment' =
 406       ("AMQP_NUMBER", numstring) : ("AMQP_FILE", fromJust path) : environment
 407 doProc _ _ _ _ _ _ _ = return ()
 408
 409 -- | ack
 410 acke :: Envelope -> Args -> IO ()
 411 acke envi a
 412   | (ack a) = ackEnv envi
 413   | otherwise = return ()
 414
 415 -- | reject
 416 reje :: Envelope -> Args -> IO ()
 417 reje envi a
 418   | (ack a) = rejectEnv envi (requeuenack a)
 419   | otherwise = return ()
 420
 421 -- | main loop: sleep forever or wait for an exception
 422 sleepingBeauty :: IO (X.SomeException)
 423 sleepingBeauty =
 424   X.catch
 425     (forever (threadDelay 600000000) >>
 426      return (X.toException $ X.ErrorCall "not reached"))
 427     return
 428
 429 -- | extract first input file in case only one is needed
 430 firstInputFile :: [(RawFilePath,String,String)] -> RawFilePath
 431 firstInputFile []          = "-"
 432 firstInputFile ((x,_,_):_) = x
 433
 434 -- | read RawFilePath to Lazy ByteString
 435 readFileRawLazy :: RawFilePath -> IO BL.ByteString
 436 readFileRawLazy path = do
 437   h <- openFd path ReadOnly defaultFlags >>= fdToHandle
 438   hSetBinaryMode h True
 439   BL.hGetContents h
 440   where
 441     defaultFlags = defaultFileFlags { noctty = True }