Network/AMQP/Utils/Options.hs

   1 -- SPDX-FileCopyrightText: 2022 Frank Doepper
   2 --
   3 -- SPDX-License-Identifier: GPL-3.0-only
   4
   5 {-# LANGUAGE OverloadedStrings #-}
   6
   7 module Network.AMQP.Utils.Options where
   8
   9 import qualified Data.ByteString.Char8            as BS
  10 import           Data.Default.Class
  11 import           Data.Int                         (Int64)
  12 import qualified Data.Map                         as M
  13 import           Data.Maybe
  14 import           Data.Text                        (Text, pack)
  15 import           Data.Version                     (showVersion)
  16 import           Data.Word                        (Word16)
  17 import           Network.AMQP
  18 import           Network.AMQP.Types
  19 import           Network.Socket                   (PortNumber)
  20 import           Paths_amqp_utils                 (version)
  21 import           System.Console.GetOpt
  22 import           System.FilePath.Posix.ByteString (RawFilePath)
  23 import           Text.Read                        (readMaybe)
  24
  25 portnumber :: Args -> PortNumber
  26 portnumber a
  27   | (port a) == Nothing && (tls a) = 5671
  28   | (port a) == Nothing = 5672
  29   | otherwise = fromJust (port a)
  30
  31 -- | A data type for our options
  32 data Args =
  33   Args
  34     { server          :: String
  35     , port            :: Maybe PortNumber
  36     , tls             :: Bool
  37     , vHost           :: String
  38     , currentExchange :: String
  39     , bindings        :: [(String, String)]
  40     , rKey            :: String
  41     , anRiss          :: Maybe Int64
  42     , fileProcess     :: Maybe String
  43     , qName           :: Maybe String
  44     , cert            :: Maybe String
  45     , key             :: Maybe String
  46     , user            :: String
  47     , pass            :: String
  48     , preFetch        :: Word16
  49     , heartBeat       :: Maybe Word16
  50     , tempDir         :: Maybe String
  51     , additionalArgs  :: [String]
  52     , connectionName  :: Maybe String
  53     , tmpQName        :: String
  54     , inputFiles      :: [(RawFilePath,String,String)]
  55     , outputFile      :: String
  56     , lineMode        :: Bool
  57     , confirm         :: Bool
  58     , msgid           :: Maybe Text
  59     , msgtype         :: Maybe Text
  60     , userid          :: Maybe Text
  61     , appid           :: Maybe Text
  62     , clusterid       :: Maybe Text
  63     , contenttype     :: Maybe Text
  64     , contentencoding :: Maybe Text
  65     , replyto         :: Maybe Text
  66     , prio            :: Maybe Octet
  67     , corrid          :: Maybe Text
  68     , msgexp          :: Maybe Text
  69     , msgheader       :: Maybe FieldTable
  70     , fnheader        :: [String]
  71     , suffix          :: [BS.ByteString]
  72     , magic           :: Bool
  73     , persistent      :: Maybe DeliveryMode
  74     , ack             :: Bool
  75     , requeuenack     :: Bool
  76     , rpc_timeout     :: Double
  77     , connect_timeout :: Int
  78     , simple          :: Bool
  79     , cleanupTmpFile  :: Bool
  80     , removeSentFile  :: Bool
  81     , moveSentFileTo  :: Maybe RawFilePath
  82     , initialScan     :: Bool
  83     , streamoffset    :: FieldTable
  84     }
  85
  86 instance Default Args where
  87   def =
  88     Args
  89       "localhost"
  90       Nothing
  91       False
  92       "/"
  93       ""
  94       []
  95       ""
  96       Nothing
  97       Nothing
  98       Nothing
  99       Nothing
 100       Nothing
 101       "guest"
 102       "guest"
 103       1
 104       Nothing
 105       Nothing
 106       []
 107       Nothing
 108       ""
 109       []
 110       "-"
 111       False
 112       False
 113       Nothing
 114       Nothing
 115       Nothing
 116       Nothing
 117       Nothing
 118       Nothing
 119       Nothing
 120       Nothing
 121       Nothing
 122       Nothing
 123       Nothing
 124       Nothing
 125       []
 126       []
 127       False
 128       Nothing
 129       True
 130       True
 131       5
 132       600
 133       False
 134       False
 135       False
 136       Nothing
 137       False
 138       (FieldTable M.empty)
 139
 140 -- | all options
 141 allOptions :: [(String, OptDescr (Args -> Args))]
 142 allOptions =
 143   [ ( "k"
 144     , Option
 145         ['r']
 146         ["bindingkey"]
 147         (ReqArg
 148            (\s o -> o {bindings = (currentExchange o, s) : (bindings o)})
 149            "BINDINGKEY")
 150         ("AMQP binding key"))
 151   , ( "kr"
 152     , Option
 153         ['X']
 154         ["execute"]
 155         (OptArg
 156            (\s o ->
 157               o
 158                 { fileProcess = Just (fromMaybe callback s)
 159                 , tempDir = Just (fromMaybe "/tmp" (tempDir o))
 160                 })
 161            "EXE")
 162         ("Callback Script File (implies -t) (-X without arg: " ++
 163          callback ++ ")"))
 164   , ( "kr"
 165     , Option
 166         ['a']
 167         ["args", "arg"]
 168         (ReqArg (\s o -> o {additionalArgs = s : (additionalArgs o)}) "ARG")
 169         "additional argument for -X callback")
 170   , ( "kr"
 171     , Option
 172         ['t']
 173         ["tempdir", "target"]
 174         (OptArg (\s o -> o {tempDir = Just (fromMaybe "/tmp" s)}) "DIR")
 175         "tempdir (default: no file creation, -t without arg: /tmp)")
 176   , ( "kr"
 177     , Option
 178         ['f']
 179         ["prefetch"]
 180         (ReqArg (\s o -> o {preFetch = read s}) "INT")
 181         ("Prefetch count. (0=unlimited, 1=off, default: " ++
 182          show (preFetch def) ++ ")"))
 183   , ( "kr"
 184     , Option
 185         ['A']
 186         ["ack"]
 187         (NoArg (\o -> o {ack = not (ack o)}))
 188         ("Toggle ack messages (default: " ++ show (ack def) ++ ")"))
 189   , ( "kr"
 190     , Option
 191         ['R']
 192         ["requeuenack"]
 193         (NoArg (\o -> o {requeuenack = not (requeuenack o)}))
 194         ("Toggle requeue when rejected (default: " ++
 195          show (requeuenack def) ++ ")"))
 196   , ( "a"
 197     , Option
 198         ['r']
 199         ["routingkey"]
 200         (ReqArg (\s o -> o {rKey = s}) "ROUTINGKEY")
 201         "AMQP routing key")
 202   , ( "p"
 203     , Option
 204         ['r', 'Q']
 205         ["routingkey", "qname"]
 206         (ReqArg (\s o -> o {rKey = s}) "ROUTINGKEY")
 207         "AMQP routing key")
 208   , ( "ap"
 209     , Option
 210         ['f']
 211         ["inputfile"]
 212         (ReqArg (\s o -> o {inputFiles = (BS.pack s,currentExchange o,rKey o):(inputFiles o)}) "INPUTFILE")
 213         ("Message input file (default: <stdin>)"))
 214   , ( "p"
 215     , Option
 216         ['O']
 217         ["outputfile"]
 218         (ReqArg (\s o -> o {outputFile = s}) "OUTPUTFILE")
 219         ("Message output file (default: " ++ (outputFile def) ++ ")"))
 220   , ( "a"
 221     , Option
 222         ['l']
 223         ["linemode"]
 224         (NoArg (\o -> o {lineMode = not (lineMode o)}))
 225         ("Toggle line-by-line mode (default: " ++ show (lineMode def) ++ ")"))
 226   , ( "a"
 227     , Option
 228         ['C']
 229         ["confirm"]
 230         (NoArg (\o -> o {confirm = not (confirm o)}))
 231         ("Toggle confirms (default: " ++ show (confirm def) ++ ")"))
 232   , ( "a"
 233     , Option
 234         []
 235         ["msgid"]
 236         (ReqArg (\s o -> o {msgid = Just $ pack s}) "ID")
 237         "Message ID")
 238   , ( "a"
 239     , Option
 240         []
 241         ["type"]
 242         (ReqArg (\s o -> o {msgtype = Just $ pack s}) "TYPE")
 243         "Message Type")
 244   , ( "a"
 245     , Option
 246         []
 247         ["userid"]
 248         (ReqArg (\s o -> o {userid = Just $ pack s}) "USERID")
 249         "Message User-ID")
 250   , ( "a"
 251     , Option
 252         []
 253         ["appid"]
 254         (ReqArg (\s o -> o {appid = Just $ pack s}) "APPID")
 255         "Message App-ID")
 256   , ( "a"
 257     , Option
 258         []
 259         ["clusterid"]
 260         (ReqArg (\s o -> o {clusterid = Just $ pack s}) "CLUSTERID")
 261         "Message Cluster-ID")
 262   , ( "a"
 263     , Option
 264         []
 265         ["contenttype"]
 266         (ReqArg (\s o -> o {contenttype = Just $ pack s}) "CONTENTTYPE")
 267         "Message Content-Type")
 268   , ( "a"
 269     , Option
 270         []
 271         ["contentencoding"]
 272         (ReqArg (\s o -> o {contentencoding = Just $ pack s}) "CONTENTENCODING")
 273         "Message Content-Encoding")
 274   , ( "a"
 275     , Option
 276         []
 277         ["replyto"]
 278         (ReqArg (\s o -> o {replyto = Just $ pack s}) "REPLYTO")
 279         "Message Reply-To")
 280   , ( "p"
 281     , Option
 282         ['t']
 283         ["rpc_timeout"]
 284         (ReqArg (\s o -> o {rpc_timeout = read s}) "SECONDS")
 285         ("How long to wait for reply (default: " ++
 286          show (rpc_timeout def) ++ ")"))
 287   , ( "a"
 288     , Option
 289         []
 290         ["prio"]
 291         (ReqArg (\s o -> o {prio = Just $ read s}) "PRIO")
 292         "Message Priority")
 293   , ( "ap"
 294     , Option
 295         []
 296         ["corrid"]
 297         (ReqArg (\s o -> o {corrid = Just $ pack s}) "CORRID")
 298         "Message CorrelationID")
 299   , ( "ap"
 300     , Option
 301         []
 302         ["exp"]
 303         (ReqArg (\s o -> o {msgexp = Just $ pack s}) "EXP")
 304         "Message Expiration")
 305   , ( "ap"
 306     , Option
 307         ['h']
 308         ["header"]
 309         (ReqArg
 310            (\s o -> o {msgheader = addheader (msgheader o) s})
 311            "HEADER=VALUE")
 312         "Message Headers")
 313   , ( "k"
 314     , Option
 315         []
 316         ["stream_offset"]
 317         (ReqArg
 318            (\s o -> o {streamoffset = mkStreamOffset s})
 319            "OFFSET")
 320         "x-stream-offset consumer argument")
 321   , ( "a"
 322     , Option
 323         ['F']
 324         ["fnheader"]
 325         (ReqArg (\s o -> o {fnheader = s : (fnheader o)}) "HEADERNAME")
 326         "Put filename into this header")
 327   , ( "a"
 328     , Option
 329         ['S']
 330         ["suffix"]
 331         (ReqArg (\s o -> o {suffix = (BS.pack s) : (suffix o)}) "SUFFIX")
 332         "Allowed file suffixes in hotfolder mode")
 333   , ( "a"
 334     , Option
 335         ['u']
 336         ["remove", "move"]
 337         (OptArg (\s o -> o {removeSentFile = True, moveSentFileTo = fmap BS.pack s}) "DIR")
 338         ("Remove (or move to DIR) sent file in hotfolder mode"))
 339   , ( "a"
 340     , Option
 341         ['d']
 342         ["dirscan"]
 343         (NoArg (\o -> o {initialScan = not (initialScan o)}))
 344         ("Toggle initial directory scan in hotfolder mode (default: " ++
 345          show (initialScan def) ++ ")"))
 346   , ( "a"
 347     , Option
 348         ['m']
 349         ["magic"]
 350         (NoArg (\o -> o {magic = not (magic o)}))
 351         ("Toggle setting content-type and -encoding from file contents (default: " ++
 352          show (magic def) ++ ")"))
 353   , ( "a"
 354     , Option
 355         ['e']
 356         ["persistent"]
 357         (NoArg (\o -> o {persistent = Just Persistent}))
 358         "Set persistent delivery")
 359   , ( "a"
 360     , Option
 361         ['E']
 362         ["nonpersistent"]
 363         (NoArg (\o -> o {persistent = Just NonPersistent}))
 364         "Set nonpersistent delivery")
 365   , ( "krp"
 366     , Option
 367         ['l']
 368         ["charlimit"]
 369         (ReqArg (\s o -> o {anRiss = Just (read s)}) "INT")
 370         "limit number of shown body chars (default: unlimited)")
 371   , ( "kr"
 372     , Option
 373         ['q']
 374         ["queue"]
 375         (ReqArg (\s o -> o {qName = Just s}) "QUEUENAME")
 376         "Ignore Exchange and bind to existing Queue")
 377   , ( "kr"
 378     , Option
 379         ['i']
 380         ["simple"]
 381         (NoArg
 382            (\o -> o {simple = True, cleanupTmpFile = not (cleanupTmpFile o)}))
 383         "call callback with one arg (filename) only")
 384   , ( "kr"
 385     , Option
 386         ['j']
 387         ["cleanup"]
 388         (NoArg (\o -> o {cleanupTmpFile = not (cleanupTmpFile o)}))
 389         "Toggle remove tempfile after script call. Default False, but default True if --simple (-i)")
 390   , ( "kr"
 391     , Option
 392         ['Q']
 393         ["qname"]
 394         (ReqArg (\s o -> o {tmpQName = s}) "TEMPQNAME")
 395         "Name for temporary exclusive Queue")
 396   , ( "akrp"
 397     , Option
 398         ['x']
 399         ["exchange"]
 400         (ReqArg (\s o -> o {currentExchange = s}) "EXCHANGE")
 401         ("AMQP Exchange (default: \"\")"))
 402   , ( "akrp"
 403     , Option
 404         ['o']
 405         ["server"]
 406         (ReqArg (\s o -> o {server = s}) "SERVER")
 407         ("AMQP Server (default: " ++ server def ++ ")"))
 408   , ( "akrp"
 409     , Option
 410         ['y']
 411         ["vhost"]
 412         (ReqArg (\s o -> o {vHost = s}) "VHOST")
 413         ("AMQP Virtual Host (default: " ++ vHost def ++ ")"))
 414   , ( "akrp"
 415     , Option
 416         ['p']
 417         ["port"]
 418         (ReqArg (\s o -> o {port = Just (read s)}) "PORT")
 419         ("Server Port Number (default: " ++ show (portnumber def) ++ ")"))
 420   , ( "akrp"
 421     , Option
 422         ['T']
 423         ["tls"]
 424         (NoArg (\o -> o {tls = not (tls o)}))
 425         ("Toggle TLS (default: " ++ show (tls def) ++ ")"))
 426   , ( "akrp"
 427     , Option
 428         ['c']
 429         ["cert"]
 430         (ReqArg (\s o -> o {cert = Just s}) "CERTFILE")
 431         ("TLS Client Certificate File"))
 432   , ( "akrp"
 433     , Option
 434         ['k']
 435         ["key"]
 436         (ReqArg (\s o -> o {key = Just s}) "KEYFILE")
 437         ("TLS Client Private Key File"))
 438   , ( "akrp"
 439     , Option
 440         ['U']
 441         ["user"]
 442         (ReqArg (\s o -> o {user = s}) "USERNAME")
 443         ("Username for Auth"))
 444   , ( "akrp"
 445     , Option
 446         ['P']
 447         ["pass"]
 448         (ReqArg (\s o -> o {pass = s}) "PASSWORD")
 449         ("Password for Auth"))
 450   , ( "akrp"
 451     , Option
 452         ['s']
 453         ["heartbeats"]
 454         (ReqArg (\s o -> o {heartBeat = (Just (read s))}) "INT")
 455         "heartbeat interval (0=disable, default: set by server)")
 456   , ( "akrp"
 457     , Option
 458         ['n']
 459         ["name"]
 460         (ReqArg (\s o -> o {connectionName = Just s}) "NAME")
 461         "connection name, will be shown in RabbitMQ web interface")
 462   , ( "akrp"
 463     , Option
 464         ['w']
 465         ["connect_timeout"]
 466         (ReqArg (\s o -> o {connect_timeout = read s}) "SECONDS")
 467         ("timeout for establishing initial connection (default: " ++
 468          show (connect_timeout def) ++ ")"))
 469   ]
 470
 471 -- | Options for the executables
 472 options :: Char -> [OptDescr (Args -> Args)]
 473 options exename = map snd $ filter ((elem exename) . fst) allOptions
 474
 475 -- | Add a header with a String value
 476 addheader :: Maybe FieldTable -> String -> Maybe FieldTable
 477 addheader Nothing string =
 478   Just $ FieldTable $ M.singleton (getkey string) (getval string)
 479 addheader (Just (FieldTable oldheader)) string =
 480   Just $ FieldTable $ M.insert (getkey string) (getval string) oldheader
 481
 482 getkey :: String -> Text
 483 getkey s = pack $ takeWhile (/= '=') s
 484
 485 getval :: String -> FieldValue
 486 getval s = FVString $ BS.pack $ tail $ dropWhile (/= '=') s
 487
 488 -- | Parse streamoffset argument as number or string
 489 mkStreamOffset :: String -> FieldTable
 490 mkStreamOffset s = FieldTable $ M.singleton (pack "x-stream-offset") value
 491   where
 492     value = maybe (FVString $ BS.pack s) FVInt32 $ readMaybe s
 493
 494 -- | 'parseargs' exename argstring
 495 -- applies options onto argstring
 496 parseargs :: Char -> [String] -> IO Args
 497 parseargs exename argstring =
 498   case getOpt Permute opt argstring of
 499     (o, [], []) -> return $ foldl (flip id) def o
 500     (_, _, errs) ->
 501       ioError $ userError $ concat errs ++ usageInfo (usage exename) opt
 502   where
 503     opt = options exename
 504
 505 -- | the default callback for the -X option
 506 callback :: String
 507 callback = "/usr/lib/haskell-amqp-utils/callback"
 508
 509 usage :: Char -> String
 510 usage exename =
 511   "\n\
 512   \amqp-utils " ++
 513   (showVersion version) ++
 514   "\n\n\
 515   \Usage:\n" ++
 516   (longname exename) ++
 517   " [options]\n\n\
 518   \Options:"
 519
 520 longname :: Char -> String
 521 longname 'a' = "agitprop"
 522 longname 'k' = "konsum"
 523 longname 'r' = "arbeite"
 524 longname 'p' = "plane"
 525 longname _   = "command"