summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs61
1 files changed, 57 insertions, 4 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 9404517..0e8970f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -25,6 +25,7 @@ import System.Environment
import Attach
import Contact
+import ICE
import Identity
import Message
import Network
@@ -95,7 +96,8 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
haveTerminalUI >>= \case True -> return ()
False -> error "Requires terminal"
extPrint <- getExternalPrint
- let extPrintLn str = extPrint $ str ++ "\n";
+ let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str
+ _ -> str ++ "\n";
server <- liftIO $ do
startServer erebosHead extPrintLn bhost
[ SomeService @AttachService Proxy
@@ -158,7 +160,10 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
let loop (Just cstate) = runMaybeT (process cstate) >>= loop
loop Nothing = return ()
- loop $ Just $ CommandState { csPeer = Nothing }
+ loop $ Just $ CommandState
+ { csPeer = Nothing
+ , csIceSessions = []
+ }
data CommandInput = CommandInput
@@ -171,6 +176,7 @@ data CommandInput = CommandInput
data CommandState = CommandState
{ csPeer :: Maybe Peer
+ , csIceSessions :: [IceSession]
}
newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
@@ -195,6 +201,11 @@ commands =
, ("contacts", cmdContacts)
, ("contact-add", cmdContactAdd)
, ("contact-accept", cmdContactAccept)
+ , ("ice-create", cmdIceCreate)
+ , ("ice-destroy", cmdIceDestroy)
+ , ("ice-show", cmdIceShow)
+ , ("ice-connect", cmdIceConnect)
+ , ("ice-send", cmdIceSend)
]
cmdUnknown :: String -> Command
@@ -212,8 +223,7 @@ showPeer peer =
PeerIdentityUnknown -> "<noid>"
PeerIdentityRef wref -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
PeerIdentityFull pid -> T.unpack $ displayIdentity pid
- DatagramAddress addr = peerAddress peer
- in name ++ " [" ++ show addr ++ "]"
+ in name ++ " [" ++ show (peerAddress peer) ++ "]"
cmdSetPeer :: Int -> Command
cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index"
@@ -276,3 +286,46 @@ cmdContactAccept = join $ contactAccept
<$> asks ciPrint
<*> asks ciHead
<*> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
+cmdIceCreate :: Command
+cmdIceCreate = do
+ role <- asks ciLine >>= return . \case
+ 'm':_ -> PjIceSessRoleControlling
+ 's':_ -> PjIceSessRoleControlled
+ _ -> PjIceSessRoleUnknown
+ eprint <- asks ciPrint
+ sess <- liftIO $ iceCreate role $ eprint <=< iceShow
+ modify $ \s -> s { csIceSessions = sess : csIceSessions s }
+
+cmdIceDestroy :: Command
+cmdIceDestroy = do
+ s:ss <- gets csIceSessions
+ modify $ \st -> st { csIceSessions = ss }
+ liftIO $ iceDestroy s
+
+cmdIceShow :: Command
+cmdIceShow = do
+ sess <- gets csIceSessions
+ eprint <- asks ciPrint
+ liftIO $ forM_ (zip [1::Int ..] sess) $ \(i, s) -> do
+ eprint $ "[" ++ show i ++ "]"
+ eprint =<< iceShow s
+
+cmdIceConnect :: Command
+cmdIceConnect = do
+ s:_ <- gets csIceSessions
+ server <- asks ciServer
+ let loadInfo = BC.getLine >>= \case line | BC.null line -> return []
+ | otherwise -> (line:) <$> loadInfo
+ Right remote <- liftIO $ do
+ st <- memoryStorage
+ pst <- derivePartialStorage st
+ rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo
+ copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes)
+ liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s
+
+cmdIceSend :: Command
+cmdIceSend = void $ do
+ s:_ <- gets csIceSessions
+ server <- asks ciServer
+ liftIO $ serverPeerIce server s