Options.hs

module Network.AMQP.Utils.Options where

import Data.Default.Class
import qualified Data.Map as M
import Data.Maybe
import Data.Text (Text, pack)
import Data.Version (showVersion)
import Network.AMQP
import Network.AMQP.Types
import Paths_amqp_utils (version)
import System.Console.GetOpt

-- | A data type for our options
data Args = Args
  { server :: String
  , port :: Int
  , tls :: Bool
  , vHost :: String
  , currentExchange :: String
  , bindings :: [(String, String)]
  , rKey :: String
  , anRiss :: Maybe Int
  , fileProcess :: Maybe String
  , qName :: Maybe String
  , cert :: Maybe String
  , key :: Maybe String
  , user :: String
  , pass :: String
  , preFetch :: Int
  , heartBeat :: Maybe Int
  , tempDir :: Maybe String
  , additionalArgs :: [String]
  , connectionName :: Maybe String
  , tmpQName :: String
  , inputFile :: String
  , lineMode :: Bool
  , confirm :: Bool
  , msgid :: Maybe Text
  , msgtype :: Maybe Text
  , userid :: Maybe Text
  , appid :: Maybe Text
  , clusterid :: Maybe Text
  , contenttype :: Maybe Text
  , contentencoding :: Maybe Text
  , replyto :: Maybe Text
  , prio :: Maybe Octet
  , corrid :: Maybe Text
  , msgexp :: Maybe Text
  , msgheader :: Maybe FieldTable
  , fnheader :: [String]
  , suffix :: [String]
  , magic :: Bool
  , persistent :: Maybe DeliveryMode
  }

instance Default Args where
  def =
    Args
      "localhost"
      5672
      False
      "/"
      "default"
      []
      ""
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      "guest"
      "guest"
      1
      Nothing
      Nothing
      []
      Nothing
      ""
      "/dev/stdin"
      False
      False
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      []
      []
      False
      Nothing

-- | Common options
cOptions :: [OptDescr (Args -> Args)]
cOptions =
  [ Option
      ['o']
      ["server"]
      (ReqArg (\s o -> o {server = s}) "SERVER")
      ("AMQP Server (default: " ++ server def ++ ")")
  , Option
      ['y']
      ["vhost"]
      (ReqArg (\s o -> o {vHost = s}) "VHOST")
      ("AMQP Virtual Host (default: " ++ vHost def ++ ")")
  , Option
      ['x']
      ["exchange"]
      (ReqArg (\s o -> o {currentExchange = s}) "EXCHANGE")
      ("AMQP Exchange (default: default)")
  , Option
      ['Q']
      ["qname"]
      (ReqArg (\s o -> o {tmpQName = s}) "TEMPQNAME")
      "Name for temporary exclusive Queue"
  , Option
      ['p']
      ["port"]
      (ReqArg (\s o -> o {port = read s}) "PORT")
      ("Server Port Number (default: " ++ show (port def) ++ ")")
  , Option
      ['T']
      ["tls"]
      (NoArg (\o -> o {tls = not (tls o)}))
      ("Toggle TLS (default: " ++ show (tls def) ++ ")")
  , Option
      ['q']
      ["queue"]
      (ReqArg (\s o -> o {qName = Just s}) "QUEUENAME")
      "Ignore Exchange and bind to existing Queue"
  , Option
      ['c']
      ["cert"]
      (ReqArg (\s o -> o {cert = Just s}) "CERTFILE")
      ("TLS Client Certificate File")
  , Option
      ['k']
      ["key"]
      (ReqArg (\s o -> o {key = Just s}) "KEYFILE")
      ("TLS Client Private Key File")
  , Option
      ['U']
      ["user"]
      (ReqArg (\s o -> o {user = s}) "USERNAME")
      ("Username for Auth")
  , Option
      ['P']
      ["pass"]
      (ReqArg (\s o -> o {pass = s}) "PASSWORD")
      ("Password for Auth")
  , Option
      ['s']
      ["heartbeats"]
      (ReqArg (\s o -> o {heartBeat = (Just (read s))}) "INT")
      "heartbeat interval (0=disable, default: set by server)"
  , Option
      ['n']
      ["name"]
      (ReqArg (\s o -> o {connectionName = Just s}) "NAME")
      "connection name, will be shown in RabbitMQ web interface"
  ]

-- | Options for konsum
kOptions :: [OptDescr (Args -> Args)]
kOptions =
  [ Option
      ['r']
      ["bindingkey"]
      (ReqArg
         (\s o -> o {bindings = (currentExchange o, s) : (bindings o)})
         "BINDINGKEY")
      ("AMQP binding key (default: #)")
  , Option
      ['X']
      ["execute"]
      (OptArg
         (\s o ->
            o
              { fileProcess = Just (fromMaybe callback s)
              , tempDir = Just (fromMaybe "/tmp" (tempDir o))
              })
         "EXE")
      ("Callback Script File (implies -t) (-X without arg: " ++ callback ++ ")")
  , Option
      ['a']
      ["args"]
      (ReqArg (\s o -> o {additionalArgs = s : (additionalArgs o)}) "ARG")
      "additional argument for -X callback"
  , Option
      ['l']
      ["charlimit"]
      (ReqArg (\s o -> o {anRiss = Just (read s :: Int)}) "INT")
      "limit number of shown body chars (default: unlimited)"
  , Option
      ['t']
      ["tempdir", "target"]
      (OptArg (\s o -> o {tempDir = Just (fromMaybe "/tmp" s)}) "DIR")
      "tempdir (default: no file creation, -t without arg: /tmp)"
  , Option
      ['f']
      ["prefetch"]
      (ReqArg (\s o -> o {preFetch = read s}) "INT")
      ("Prefetch count. (0=unlimited, 1=off, default: " ++
       show (preFetch def) ++ ")")
  ]

-- | Options for agitprop
aOptions :: [OptDescr (Args -> Args)]
aOptions =
  [ Option
      ['r']
      ["routingkey"]
      (ReqArg (\s o -> o {rKey = s}) "ROUTINGKEY")
      "AMQP routing key"
  , Option
      ['f']
      ["inputfile"]
      (ReqArg (\s o -> o {inputFile = s}) "INPUTFILE")
      ("Message input file (default: " ++ (inputFile def) ++ ")")
  , Option
      ['l']
      ["linemode"]
      (NoArg (\o -> o {lineMode = not (lineMode o)}))
      ("Toggle line-by-line mode (default: " ++ show (lineMode def) ++ ")")
  , Option
      ['C']
      ["confirm"]
      (NoArg (\o -> o {confirm = not (confirm o)}))
      ("Toggle confirms (default: " ++ show (confirm def) ++ ")")
  , Option
      []
      ["msgid"]
      (ReqArg (\s o -> o {msgid = Just $ pack s}) "ID")
      "Message ID"
  , Option
      []
      ["type"]
      (ReqArg (\s o -> o {msgtype = Just $ pack s}) "TYPE")
      "Message Type"
  , Option
      []
      ["userid"]
      (ReqArg (\s o -> o {userid = Just $ pack s}) "USERID")
      "Message User-ID"
  , Option
      []
      ["appid"]
      (ReqArg (\s o -> o {appid = Just $ pack s}) "APPID")
      "Message App-ID"
  , Option
      []
      ["clusterid"]
      (ReqArg (\s o -> o {clusterid = Just $ pack s}) "CLUSTERID")
      "Message Cluster-ID"
  , Option
      []
      ["contenttype"]
      (ReqArg (\s o -> o {contenttype = Just $ pack s}) "CONTENTTYPE")
      "Message Content-Type"
  , Option
      []
      ["contentencoding"]
      (ReqArg (\s o -> o {contentencoding = Just $ pack s}) "CONTENTENCODING")
      "Message Content-Encoding"
  , Option
      []
      ["replyto"]
      (ReqArg (\s o -> o {replyto = Just $ pack s}) "REPLYTO")
      "Message Reply-To"
  , Option
      []
      ["prio"]
      (ReqArg (\s o -> o {prio = Just $ read s}) "PRIO")
      "Message Priority"
  , Option
      []
      ["corrid"]
      (ReqArg (\s o -> o {corrid = Just $ pack s}) "CORRID")
      "Message CorrelationID"
  , Option
      []
      ["exp"]
      (ReqArg (\s o -> o {msgexp = Just $ pack s}) "EXP")
      "Message Expiration"
  , Option
      ['h']
      ["header"]
      (ReqArg (\s o -> o {msgheader = addheader (msgheader o) s}) "HEADER=VALUE")
      "Message Headers"
  , Option
      ['F']
      ["fnheader"]
      (ReqArg (\s o -> o {fnheader = s : (fnheader o)}) "HEADERNAME")
      "Put filename into this header"
  , Option
      ['S']
      ["suffix"]
      (ReqArg (\s o -> o {suffix = s : (suffix o)}) "SUFFIX")
      "Allowed file suffixes in hotfolder mode"
  , Option
      ['m']
      ["magic"]
      (NoArg (\o -> o {magic = not (magic o)}))
      ("Toggle setting content-type and -encoding from file contents (default: " ++
       show (magic def) ++ ")")
  , Option
      ['e']
      ["persistent"]
      (NoArg (\o -> o {persistent = Just Persistent}))
      "Set persistent delivery"
  , Option
      ['E']
      ["nonpersistent"]
      (NoArg (\o -> o {persistent = Just NonPersistent}))
      "Set nonpersistent delivery"
  ]

-- | Options for the executables
options :: String -> [OptDescr (Args -> Args)]
options "konsum" = kOptions ++ cOptions
options "agitprop" = aOptions ++ cOptions
options _ = cOptions

-- | Add a header with a String value
addheader :: Maybe FieldTable -> String -> Maybe FieldTable
addheader Nothing string = Just $ FieldTable $ M.singleton (k string) (v string)
addheader (Just (FieldTable oldheader)) string =
  Just $ FieldTable $ M.insert (k string) (v string) oldheader

k :: String -> Text
k s = pack $ takeWhile (/= '=') s

v :: String -> FieldValue
v s = FVString $ pack $ tail $ dropWhile (/= '=') s

-- | 'parseargs' exename argstring
-- applies options onto argstring
parseargs :: String -> [String] -> IO Args
parseargs exename argstring =
  case getOpt Permute opt argstring of
    (o, [], []) -> return $ foldl (flip id) def o
    (_, _, errs) ->
      ioError $ userError $ concat errs ++ usageInfo (usage exename) opt
  where
    opt = options exename

-- | the default callback for the -X option
callback :: String
callback = "/usr/lib/haskell-amqp-utils/callback"

usage :: String -> String
usage exename =
  "\n\
  \amqp-utils " ++
  (showVersion version) ++
  "\n\n\
  \Usage:\n" ++
  exename ++
  " [options]\n\n\
  \Options:"