diff options
| -rw-r--r-- | main/Test.hs | 32 | ||||
| -rw-r--r-- | src/Erebos/Invite.hs | 36 |
2 files changed, 31 insertions, 37 deletions
diff --git a/main/Test.hs b/main/Test.hs index da49257..a3b91c2 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -15,12 +15,10 @@ 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) @@ -131,26 +129,6 @@ 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 () @@ -259,11 +237,11 @@ 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) + afterCommit $ outLine out $ "invite-accepted " <> showInviteToken token <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid) , inviteHookReplyContact = \token _ -> do - afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " contact" + afterCommit $ outLine out $ "invite-accept-done " <> showInviteToken token <> " contact" , inviteHookReplyInvalid = \token -> do - afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " invalid" + afterCommit $ outLine out $ "invite-accept-done " <> showInviteToken token <> " invalid" } dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () @@ -1106,12 +1084,12 @@ cmdInviteContactCreate :: Command cmdInviteContactCreate = do [ name ] <- asks tiParams Just token <- inviteToken <$> createSingleContactInvite name - cmdOut $ unwords [ "invite-contact-create-done", BC.unpack (showHex token) ] + cmdOut $ unwords [ "invite-contact-create-done", showInviteToken token ] cmdInviteAccept :: Command cmdInviteAccept = do [ tokenText, idref ] <- asks tiParams - Just token <- return $ readHex $ encodeUtf8 tokenText + Just token <- return $ parseInviteToken tokenText Just from <- return $ readRefDigest $ encodeUtf8 idref Just RunningServer {..} <- gets tsServer acceptInvite rsServer from token diff --git a/src/Erebos/Invite.hs b/src/Erebos/Invite.hs index f860fbc..bbd280d 100644 --- a/src/Erebos/Invite.hs +++ b/src/Erebos/Invite.hs @@ -1,6 +1,7 @@ module Erebos.Invite ( Invite(..), InviteData(..), + InviteToken, showInviteToken, textInviteToken, parseInviteToken, InviteService, InviteServiceAttributes(..), @@ -16,11 +17,13 @@ import Control.Monad.Reader import Crypto.Random +import Data.ByteArray (ByteArray, ByteArrayAccess) import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.Foldable import Data.Ord import Data.Text (Text) +import Data.Text.Encoding import Erebos.Contact import Erebos.Identity @@ -37,14 +40,14 @@ import Erebos.Util data Invite = Invite { inviteData :: [ Stored InviteData ] - , inviteToken :: Maybe ByteString + , inviteToken :: Maybe InviteToken , inviteAccepted :: [ Stored (Signed ExtendedIdentityData) ] , inviteContact :: Maybe Text } data InviteData = InviteData { invdPrev :: [ Stored InviteData ] - , invdToken :: Maybe ByteString + , invdToken :: Maybe InviteToken , invdAccepted :: Maybe (Stored (Signed ExtendedIdentityData)) , invdContact :: Maybe Text } @@ -63,6 +66,19 @@ instance Storable InviteData where <*> loadMbText "contact" +newtype InviteToken = InviteToken ByteString + deriving (Eq, Ord, Semigroup, Monoid, ByteArray, ByteArrayAccess) + +showInviteToken :: InviteToken -> String +showInviteToken (InviteToken token) = BC.unpack (showHex token) + +textInviteToken :: InviteToken -> Text +textInviteToken (InviteToken token) = decodeUtf8 (showHex token) + +parseInviteToken :: Text -> Maybe InviteToken +parseInviteToken text = InviteToken <$> (readHex $ encodeUtf8 text) + + instance Mergeable Invite where type Component Invite = InviteData @@ -95,7 +111,7 @@ createSingleContactInvite name = do identityOwnerDigests :: Foldable f => Identity f -> [ RefDigest ] identityOwnerDigests pid = map (refDigest . storedRef) $ concatMap toList $ toList $ generations $ idExtDataF $ finalOwner pid -acceptInvite :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> ByteString -> m () +acceptInvite :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> InviteToken -> m () acceptInvite server from token = do let matchPeer peer = do getPeerIdentity peer >>= \case @@ -111,15 +127,15 @@ acceptInvite server from token = do data InviteService - = AcceptInvite ByteString - | InvalidInvite ByteString - | ContactInvite ByteString (Maybe Text) + = AcceptInvite InviteToken + | InvalidInvite InviteToken + | ContactInvite InviteToken (Maybe Text) | UnknownInvitePacket data InviteServiceAttributes = InviteServiceAttributes - { inviteHookAccepted :: ByteString -> ServiceHandler InviteService () - , inviteHookReplyContact :: ByteString -> Maybe Text -> ServiceHandler InviteService () - , inviteHookReplyInvalid :: ByteString -> ServiceHandler InviteService () + { inviteHookAccepted :: InviteToken -> ServiceHandler InviteService () + , inviteHookReplyContact :: InviteToken -> Maybe Text -> ServiceHandler InviteService () + , inviteHookReplyInvalid :: InviteToken -> ServiceHandler InviteService () } defaultInviteServiceAttributes :: InviteServiceAttributes @@ -151,7 +167,7 @@ instance Storable InviteService where instance Service InviteService where serviceID _ = mkServiceID "70bff715-6856-43a0-8c58-007a06a26eb1" - type ServiceState InviteService = [ ByteString ] -- accepted invites, waiting for reply + type ServiceState InviteService = [ InviteToken ] -- accepted invites, waiting for reply emptyServiceState _ = [] type ServiceAttributes InviteService = InviteServiceAttributes |