Network/AMQP/Utils/Options.hs

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