ICE config for each discovery peer

1 files changed, 52 insertions, 6 deletions

diff --git a/main/Main.hs b/main/Main.hs
index db141cf..c9c9156 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -123,6 +123,20 @@ options =
     , Option [] ["chatroom-auto-subscribe"]
         (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")
         "automatically subscribe for up to <count> chatrooms"
+#ifdef ENABLE_ICE_SUPPORT
+    , Option [] [ "discovery-stun-port" ]
+        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunPort = Just (read value) }) "<port>")
+        "offer specified <port> to discovery peers for STUN protocol"
+    , Option [] [ "discovery-stun-server" ]
+        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunServer = Just (read value) }) "<server>")
+        "offer <server> (domain name or IP address) to discovery peers for STUN protocol"
+    , Option [] [ "discovery-turn-port" ]
+        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnPort = Just (read value) }) "<port>")
+        "offer specified <port> to discovery peers for TURN protocol"
+    , Option [] [ "discovery-turn-server" ]
+        (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnServer = Just (read value) }) "<server>")
+        "offer <server> (domain name or IP address) to discovery peers for TURN protocol"
+#endif
     , Option [] ["dm-bot-echo"]
         (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
         "automatically reply to direct messages with the same text prefixed with <prefix>"
@@ -133,7 +147,16 @@ options =
         (NoArg $ \opts -> opts { optShowVersion = True })
         "show version and exit"
     ]
-    where so f opts = opts { optServer = f $ optServer opts }
+  where
+    so f opts = opts { optServer = f $ optServer opts }
+
+    updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService
+    updateService f some@(SomeService proxy attrs)
+        | Just f' <- cast f = SomeService proxy (f' attrs)
+        | otherwise = some
+
+    serviceAttr :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> Options -> Options
+    serviceAttr f opts = opts { optServices = map (\sopt -> sopt { soptService = updateService f (soptService sopt) }) (optServices opts) }
 
 servicesOptions :: [OptDescr (Options -> Options)]
 servicesOptions = concatMap helper $ "all" : map soptName availableServices
@@ -867,12 +890,35 @@ cmdDiscovery = void $ do
 
 cmdIceCreate :: Command
 cmdIceCreate = do
-    role <- asks ciLine >>= return . \case
-        'm':_ -> PjIceSessRoleControlling
-        's':_ -> PjIceSessRoleControlled
-        _ -> PjIceSessRoleUnknown
+    let getRole = \case
+            'm':_ -> PjIceSessRoleControlling
+            's':_ -> PjIceSessRoleControlled
+            _ -> PjIceSessRoleUnknown
+
+    ( role, stun, turn ) <- asks (words . ciLine) >>= \case
+        [] -> return ( PjIceSessRoleControlling, Nothing, Nothing )
+        [ role ] -> return
+            ( getRole role, Nothing, Nothing )
+        [ role, server ] -> return
+            ( getRole role
+            , Just ( T.pack server, 0 )
+            , Just ( T.pack server, 0 )
+            )
+        [ role, server, port ] -> return
+            ( getRole role
+            , Just ( T.pack server, read port )
+            , Just ( T.pack server, read port )
+            )
+        [ role, stunServer, stunPort, turnServer, turnPort ] -> return
+            ( getRole role
+            , Just ( T.pack stunServer, read stunPort )
+            , Just ( T.pack turnServer, read turnPort )
+            )
+        _ -> throwError "invalid parameters"
+
     eprint <- asks ciPrint
-    sess <- liftIO $ iceCreate role $ eprint <=< iceShow
+    Just cfg <- liftIO $ iceCreateConfig stun turn
+    sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow
     modify $ \s -> s { csIceSessions = sess : csIceSessions s }
 
 cmdIceDestroy :: Command