diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Test.hs | 51 |
1 files changed, 51 insertions, 0 deletions
diff --git a/main/Test.hs b/main/Test.hs index 42e9c94..17dc228 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -15,10 +15,12 @@ import Control.Monad.State import Crypto.Random import Data.Bool +import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.ByteString.Lazy.Char8 qualified as BL +import Data.Char import Data.Foldable import Data.Ord import Data.Text (Text) @@ -39,6 +41,7 @@ import Erebos.Contact import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity +import Erebos.Invite import Erebos.Network import Erebos.Object import Erebos.Pairing @@ -128,6 +131,26 @@ getHead = do modify $ \s -> s { tsHead = Just h } return h +showHex :: ByteString -> ByteString +showHex = B.concat . map showHexByte . B.unpack + where showHexChar x | x < 10 = x + o '0' + | otherwise = x + o 'a' - 10 + showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ] + o = fromIntegral . ord + +readHex :: ByteString -> Maybe ByteString +readHex = return . B.concat <=< readHex' + where readHex' bs | B.null bs = Just [] + readHex' bs = do (bx, bs') <- B.uncons bs + (by, bs'') <- B.uncons bs' + x <- hexDigit bx + y <- hexDigit by + (B.singleton (x * 16 + y) :) <$> readHex' bs'' + hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0' + | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10 + | otherwise = Nothing + o = fromIntegral . ord + type Output = MVar () @@ -232,6 +255,17 @@ discoveryAttributes = (defaultServiceAttributes Proxy) { discoveryProvideTunnel = \_ _ -> False } +inviteAttributes :: Output -> InviteServiceAttributes +inviteAttributes out = (defaultServiceAttributes Proxy) + { inviteHookAccepted = \token -> do + pid <- asks svcPeerIdentity + afterCommit $ outLine out $ "invite-accepted " <> BC.unpack (showHex token) <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid) + , inviteHookReplyContact = \token _ -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " contact" + , inviteHookReplyInvalid = \token -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " invalid" + } + dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () dmThreadWatcher self out prev cur = do forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do @@ -327,6 +361,8 @@ commands = , ( "chatroom-message-send", cmdChatroomMessageSend ) , ( "discovery-connect", cmdDiscoveryConnect ) , ( "discovery-tunnel", cmdDiscoveryTunnel ) + , ( "invite-contact-create", cmdInviteContactCreate ) + , ( "invite-accept", cmdInviteAccept ) ] cmdStore :: Command @@ -572,6 +608,7 @@ cmdStartServer = do { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params } ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out + ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out ( "sync", _ ) -> return $ someService @SyncService Proxy ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) { testMessageReceived = \obj otype len sref -> do @@ -1043,3 +1080,17 @@ cmdDiscoveryTunnel = do via <- getPeer tvia Just target <- return $ readRefDigest $ encodeUtf8 ttarget liftIO $ discoverySetupTunnel via target + +cmdInviteContactCreate :: Command +cmdInviteContactCreate = do + [ name ] <- asks tiParams + Just token <- inviteToken <$> createSingleContactInvite name + cmdOut $ unwords [ "invite-contact-create-done", BC.unpack (showHex token) ] + +cmdInviteAccept :: Command +cmdInviteAccept = do + [ tokenText, idref ] <- asks tiParams + Just token <- return $ readHex $ encodeUtf8 tokenText + Just from <- return $ readRefDigest $ encodeUtf8 idref + Just RunningServer {..} <- gets tsServer + acceptInvite rsServer from token |