--help for dhtd

1 files changed, 30 insertions, 4 deletions

diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index 2772416b..e0b58539 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -47,6 +47,7 @@ import GHC.Conc (threadStatus,ThreadStatus(..))
 import GHC.Stats
 import Network.Socket
 import System.Environment
+import System.Exit
 import System.IO
 import System.Mem
 import System.Posix.Process
@@ -121,6 +122,7 @@ import DebugTag
 import LocalChat
 import ToxChat
 import MUC
+import Data.Either
 
 
 pshow :: Show a => a -> B.ByteString
@@ -1135,10 +1137,33 @@ sensibleDefaults = Options
     , verboseTags = [XUnexpected, XUnused]
     }
 
+data ShowHelp = ShowHelp
+    deriving (Eq,Show)
+
+usage ShowHelp
+ = let { cs = [ ([["--help"]]           ,["display this help"])
+             , ([["--dhtkey ",dhtkey]
+                ,["--dht-key ",dhtkey]],["use ",dhtkey," as the dht key"])
+             , ([["-4"]]               ,["Use IPv4 only"])
+             , ([["-v ",tags]]         ,["Enable or disable specified DebugTags.\n        DebugTags = ", listDebugTags])
+             ] ;
+         dhtkey ="<dhtkey>" ;
+         tags  = "[-]Tag1,[-]Tag2,... " ;
+         -- TODO: word-wrap listDebugTags for terminal width
+         listDebugTags = intercalate ", " $ map ((drop 1) . show) ([minBound .. maxBound]::[DebugTag]) ;
+       } in do
+            putStrLn "dhtd OPTIONS\n"
+            forM cs $ \(how,what) -> do
+                forM how $ putStrLn . ("    "++) . concat
+                putStr "\t"
+                putStrLn . concat $ what
+            exitFailure
+
 -- bt=<port>,tox=<port>
 -- -4
-parseArgs :: [String] -> Options -> Options
-parseArgs []                  opts = opts
+parseArgs :: [String] -> Options -> Either ShowHelp Options
+parseArgs []              opts = Right opts
+parseArgs ("--help":args) opts = Left ShowHelp
 parseArgs ("--dhtkey":k:args) opts = parseArgs args opts
     { dhtkey = decodeSecret $ B.pack k }
 parseArgs ("--dht-key":k:args) opts = parseArgs args opts
@@ -1619,8 +1644,9 @@ initJabber opts ssvar announcer mbtox toxdhts toxchat = case portxmpp opts of
 main :: IO ()
 main = do
     args <- getArgs
-    let opts = parseArgs args sensibleDefaults
-    print opts
+    let eopts = parseArgs args sensibleDefaults
+    either usage print eopts -- quits on left
+    let Right opts = eopts
 
     swarms <- Mainline.newSwarmsDatabase
     -- Restore peer database before forking the listener thread.