Debug logs in discovery service

1 files changed, 20 insertions, 1 deletions

diff --git a/main/Main.hs b/main/Main.hs
index f3fa0b8..da71e6a 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -204,6 +204,25 @@ options =
         tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ]
         return $ \_ _ -> False
 
+debugOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]
+debugOptions =
+    [ Option [] [ "discovery-debug-log" ]
+        (NoArg (serviceAttr $ \attrs -> return attrs { discoveryDebugLog = True }))
+        ""
+    ]
+  where
+    updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService
+    updateService f some@(SomeService proxy attrs)
+        | Just f' <- cast f = SomeService proxy <$> f' attrs
+        | otherwise = return some
+
+    serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options
+    serviceAttr f opts = do
+        services' <- forM (optServices opts) $ \sopt -> do
+            service <- updateService f (soptService sopt)
+            return sopt { soptService = service }
+        return opts { optServices = services' }
+
 servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]
 servicesOptions = concatMap helper $ "all" : map soptName availableServices
   where
@@ -233,7 +252,7 @@ main = do
             progName <- getProgName
             hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."
             exitFailure
-    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case
+    (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions ++ debugOptions) <$> getArgs) >>= \case
         (wo, args, []) ->
             case runWriter (foldM (flip ($)) defaultOptions wo) of
                 ( o, [] )   -> return ( o, args )