Newtype wrapper for invite token

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