From 88a7bb50033baab3c2d0eed7e4be868e8966300a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 17 Nov 2023 20:28:44 +0100
Subject: Split to library and executable parts

---
 src/Erebos/Attach.hs | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 122 insertions(+)
 create mode 100644 src/Erebos/Attach.hs

(limited to 'src/Erebos/Attach.hs')

diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs
new file mode 100644
index 0000000..4fd976f
--- /dev/null
+++ b/src/Erebos/Attach.hs
@@ -0,0 +1,122 @@
+module Erebos.Attach (
+    AttachService,
+    attachToOwner,
+    attachAccept,
+    attachReject,
+) where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Data.ByteArray (ScrubbedBytes)
+import Data.Maybe
+import Data.Proxy
+import qualified Data.Text as T
+
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Pairing
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Key
+
+type AttachService = PairingService AttachIdentity
+
+data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
+
+instance Storable AttachIdentity where
+    store' (AttachIdentity x keys) = storeRec $ do
+         storeRef "identity" x
+         mapM_ (storeBinary "skey") keys
+
+    load' = loadRec $ AttachIdentity
+        <$> loadRef "identity"
+        <*> loadBinaries "skey"
+
+instance PairingResult AttachIdentity where
+    pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
+
+    type PairingVerifiedResult AttachIdentity = (UnifiedIdentity, [ScrubbedBytes])
+
+    pairingVerifyResult (AttachIdentity sdata keys) = do
+        curid <- lsIdentity . fromStored <$> svcGetLocal
+        secret <- loadKey $ eiddKeyIdentity $ fromSigned curid
+        sdata' <- mstore =<< signAdd secret (fromStored sdata)
+        return $ do
+            guard $ iddKeyIdentity (fromSigned sdata) ==
+                eiddKeyIdentity (fromSigned curid)
+            identity <- validateIdentity sdata'
+            guard $ iddPrev (fromSigned $ idData identity) == [eiddStoredBase curid]
+            return (identity, keys)
+
+    pairingFinalizeRequest (identity, keys) = updateLocalHead_ $ \slocal -> do
+        let owner = finalOwner identity
+        st <- getStorage
+        pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
+        liftIO $ mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ]
+
+        identity' <- mergeIdentity $ updateIdentity [ lsIdentity $ fromStored slocal ] identity
+        shared <- makeSharedStateUpdate st (Just owner) (lsShared $ fromStored slocal)
+        mstore (fromStored slocal)
+            { lsIdentity = idExtData identity'
+            , lsShared = [ shared ]
+            }
+
+    pairingFinalizeResponse = do
+        owner <- mergeSharedIdentity
+        pid <- asks svcPeerIdentity
+        secret <- loadKey $ idKeyIdentity owner
+        identity <- mstore =<< sign secret =<< mstore (emptyIdentityData $ idKeyIdentity pid)
+            { iddPrev = [idData pid], iddOwner = Just (idData owner) }
+        skeys <- map keyGetData . catMaybes <$> mapM loadKeyMb [ idKeyIdentity owner, idKeyMessage owner ]
+        return $ AttachIdentity identity skeys
+
+    defaultPairingAttributes _ = PairingAttributes
+        { pairingHookRequest = do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
+
+        , pairingHookResponse = \confirm -> do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm
+
+        , pairingHookRequestNonce = \confirm -> do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm
+
+        , pairingHookRequestNonceFailed = do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer)
+
+        , pairingHookConfirmedResponse = do
+            svcPrint $ "Confirmed peer, waiting for updated identity"
+
+        , pairingHookConfirmedRequest = do
+            svcPrint $ "Attachment confirmed by peer"
+
+        , pairingHookAcceptedResponse = do
+            svcPrint $ "Accepted updated identity"
+
+        , pairingHookAcceptedRequest = do
+            svcPrint $ "Accepted new attached device, seding updated identity"
+
+        , pairingHookVerifyFailed = do
+            svcPrint $ "Failed to verify new identity"
+
+        , pairingHookRejected = do
+            svcPrint $ "Attachment rejected by peer"
+
+        , pairingHookFailed = \_ -> do
+            svcPrint $ "Attachement failed"
+        }
+
+attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m ()
+attachToOwner = pairingRequest @AttachIdentity Proxy
+
+attachAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
+attachAccept = pairingAccept @AttachIdentity Proxy
+
+attachReject :: (MonadIO m, MonadError String m) => Peer -> m ()
+attachReject = pairingReject @AttachIdentity Proxy
-- 
cgit v1.2.3