Contact: shared state and service

3 files changed, 172 insertions, 0 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 2a9e65a..4e2726a 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -21,6 +21,7 @@ executable erebos
   other-modules:       Attach
                        Identity,
                        Channel,
+                       Contact
                        Message,
                        Network,
                        Pairing
diff --git a/src/Contact.hs b/src/Contact.hs
new file mode 100644
index 0000000..b725378
--- /dev/null
+++ b/src/Contact.hs
@@ -0,0 +1,147 @@
+module Contact (
+    Contact(..),
+    contactView,
+
+    ContactService,
+    contactRequest,
+    contactAccept,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Data.Maybe
+import Data.Proxy
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Identity
+import Network
+import Pairing
+import PubKey
+import Service
+import State
+import Storage
+import Storage.Merge
+
+data Contact = Contact
+    { contactIdentity :: ComposedIdentity
+    , contactName :: Maybe Text
+    }
+
+data ContactData = ContactData
+    { cdPrev :: [Stored ContactData]
+    , cdIdentity :: [Stored (Signed IdentityData)]
+    , cdName :: Maybe Text
+    }
+
+instance Storable ContactData where
+    store' x = storeRec $ do
+        mapM_ (storeRef "PREV") $ cdPrev x
+        mapM_ (storeRef "identity") $ cdIdentity x
+        storeMbText "name" $ cdName x
+
+    load' = loadRec $ ContactData
+        <$> loadRefs "PREV"
+        <*> loadRefs "identity"
+        <*> loadMbText "name"
+
+instance SharedType ContactData where
+    sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e"
+
+contactView :: [Stored ContactData] -> [Contact]
+contactView = helper [] . filterAncestors
+    where helper used (x:xs) | Just cid <- validateIdentityF (cdIdentity (fromStored x))
+                             , not $ any (sameIdentity cid) used
+                             = Contact { contactIdentity = cid
+                                       , contactName = lookupProperty cid cdName (x:xs)
+                                       } : helper (cid:used) xs
+                             | otherwise = helper used xs
+          helper _ [] = []
+
+lookupProperty :: forall a. ComposedIdentity -> (ContactData -> Maybe a) -> [Stored ContactData] -> Maybe a
+lookupProperty idt sel = join . fmap (sel . fromStored) . listToMaybe . filterAncestors . helper
+    where helper (x:xs) | Just cid <- validateIdentityF (cdIdentity (fromStored x))
+                        , cid `sameIdentity` idt
+                        , Just _ <- sel $ fromStored x
+                        = x : helper xs
+                        | otherwise = helper $ cdPrev (fromStored x) ++ xs
+          helper [] = []
+
+
+type ContactService = PairingService ContactAccepted
+
+data ContactAccepted = ContactAccepted
+
+instance Storable ContactAccepted where
+    store' ContactAccepted = storeRec $ do
+        storeText "accept" ""
+    load' = loadRec $ do
+        (_ :: T.Text) <- loadText "accept"
+        return ContactAccepted
+
+instance PairingResult ContactAccepted where
+    pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084"
+
+    pairingHookRequest = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Contact pairing from " ++ T.unpack (displayIdentity peer) ++ " initiated"
+
+    pairingHookResponse confirm = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Confirm contact " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
+
+    pairingHookRequestNonce confirm = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Contact request from " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
+
+    pairingHookRequestNonceFailed = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)
+
+    pairingHookConfirm ContactAccepted = do
+        svcPrint $ "Contact confirmed by peer"
+        return $ Just ContactAccepted
+
+    pairingHookAccept ContactAccepted = return ()
+
+contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m ()
+contactRequest _ = pairingRequest @ContactAccepted Proxy
+
+contactAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m ()
+contactAccept printMsg h peer = do
+    let self = headLocalIdentity h
+    sendToPeerWith self peer $ \case
+        NoPairing -> throwError $ "none in progress"
+        OurRequest {} -> throwError $ "waiting for peer"
+        OurRequestConfirm Nothing -> do
+            liftIO $ printMsg $ "Contact accepted, waiting for peer confirmation"
+            return (Nothing, OurRequestReady)
+        OurRequestConfirm (Just ContactAccepted) -> do
+            PeerIdentityFull pid <- return $ peerIdentity peer
+            liftIO $ do
+                printMsg $ "Contact accepted"
+                updateLocalState_ h $ finalizeContact pid
+            return (Nothing, PairingDone)
+        OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
+        PeerRequest {} -> throwError $ "waiting for peer"
+        PeerRequestConfirm -> do
+            PeerIdentityFull pid <- return $ peerIdentity peer
+            liftIO $ do
+                printMsg $ "Contact accepted"
+                updateLocalState_ h $ finalizeContact pid
+            return (Just $ PairingAccept ContactAccepted, PairingDone)
+        PairingDone -> throwError $ "alredy done"
+        PairingFailed -> throwError $ "alredy failed"
+
+finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
+finalizeContact identity slocal = liftIO $ do
+    let st = storedStorage slocal
+    contact <- wrappedStore st ContactData
+            { cdPrev = lookupSharedValue $ lsShared $ fromStored slocal
+            , cdIdentity = idDataF $ finalOwner identity
+            , cdName = Nothing
+            }
+    shared <- makeSharedStateUpdate st [contact] (lsShared $ fromStored slocal)
+    wrappedStore st (fromStored slocal) { lsShared = [shared] }
diff --git a/src/Main.hs b/src/Main.hs
index c961f4f..96186a8 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -25,6 +25,7 @@ import System.Console.Haskeline
 import System.Environment
 
 import Attach
+import Contact
 import Identity
 import Message
 import Network
@@ -100,6 +101,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
         startServer erebosHead extPrintLn bhost
             [ SomeService @AttachService Proxy
             , SomeService @SyncService Proxy
+            , SomeService @ContactService Proxy
             , SomeService @DirectMessage Proxy
             ]
 
@@ -190,6 +192,9 @@ commands =
     , ("update-identity", cmdUpdateIdentity)
     , ("attach", cmdAttach)
     , ("attach-accept", cmdAttachAccept)
+    , ("contacts", cmdContacts)
+    , ("contact-add", cmdContactAdd)
+    , ("contact-accept", cmdContactAccept)
     ]
 
 cmdUnknown :: String -> Command
@@ -252,3 +257,22 @@ cmdAttachAccept = join $ attachAccept
     <$> asks ciPrint
     <*> asks ciHead
     <*> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
+cmdContacts :: Command
+cmdContacts = do
+    ehead <- asks ciHead
+    let contacts = contactView $ lookupSharedValue $ lsShared $ headObject ehead
+    forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do
+        liftIO $ putStrLn $ show i ++ ": " ++ T.unpack (displayIdentity $ contactIdentity c)
+
+cmdContactAdd :: Command
+cmdContactAdd = join $ contactRequest
+    <$> asks ciPrint
+    <*> asks (headLocalIdentity . ciHead)
+    <*> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
+cmdContactAccept :: Command
+cmdContactAccept = join $ contactAccept
+    <$> asks ciPrint
+    <*> asks ciHead
+    <*> (maybe (throwError "no peer selected") return =<< gets csPeer)