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