Pairing: refactor common logic into the base module

4 files changed, 141 insertions, 129 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
index e028718..c220e14 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -22,20 +22,56 @@ import Storage.Key
 
 type AttachService = PairingService AttachIdentity
 
-data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] (Maybe UnifiedIdentity)
+data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
 
 instance Storable AttachIdentity where
-    store' (AttachIdentity x keys _) = storeRec $ do
+    store' (AttachIdentity x keys) = storeRec $ do
          storeRef "identity" x
          mapM_ (storeBinary "skey") keys
 
     load' = loadRec $ AttachIdentity
         <$> loadRef "identity"
         <*> loadBinaries "skey"
-        <*> pure Nothing
 
 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 <- maybe (throwError "failed to load own secret key") return =<<
+            liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid)
+        sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata)
+        return $ do
+            guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) ==
+                iddKeyIdentity (fromStored $ signedData $ fromStored curid)
+            identity <- validateIdentity sdata'
+            guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid]
+            return (identity, keys)
+
+    pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> do
+        let owner = finalOwner identity
+            st = storedStorage slocal
+        pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
+        mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ]
+
+        shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal)
+        wrappedStore st (fromStored slocal)
+            { lsIdentity = idData identity
+            , lsShared = [ shared ]
+            }
+
+    pairingFinalizeResponse = do
+        st <- storedStorage <$> svcGetLocal
+        owner <- mergeSharedIdentity
+        pid <- asks svcPeerIdentity
+        secret <- maybe (throwError "failed to load secret key") return =<< liftIO (loadKey $ idKeyIdentity owner)
+        identity <- liftIO $ wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid)
+            { iddPrev = [idData pid], iddOwner = Just (idData owner) }
+        skeys <- liftIO $ map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ]
+        return $ AttachIdentity identity skeys
+
     defaultPairingAttributes _ = PairingAttributes
         { pairingHookRequest = do
             peer <- asks $ svcPeerIdentity
@@ -53,81 +89,24 @@ instance PairingResult AttachIdentity where
             peer <- asks $ svcPeerIdentity
             svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer)
 
-        , pairingHookConfirm = \(AttachIdentity sdata keys _) -> do
-            verifyAttachedIdentity sdata >>= \case
-                Just identity -> do
-                    svcPrint $ "Attachment confirmed by peer"
-                    return $ Just $ AttachIdentity sdata keys (Just identity)
-                Nothing -> do
-                    svcPrint $ "Failed to verify new identity"
-                    throwError "Failed to verify new identity"
-
-        , pairingHookAccept = \(AttachIdentity sdata keys _) -> do
-            verifyAttachedIdentity sdata >>= \case
-                Just identity -> do
-                    svcPrint $ "Accepted updated identity"
-                    svcSetLocal =<< finalizeAttach identity keys =<< svcGetLocal
-                Nothing -> do
-                    svcPrint $ "Failed to verify new identity"
-                    throwError "Failed to verify new identity"
-        }
+        , pairingHookConfirmedResponse = do
+            svcPrint $ "Confirmed peer, waiting for updated identity"
+
+        , pairingHookConfirmedRequest = do
+            svcPrint $ "Attachment confirmed by peer"
 
-attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m ()
-attachToOwner _ = pairingRequest @AttachIdentity Proxy
-
-attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m ()
-attachAccept printMsg h peer = do
-    let st = refStorage $ headRef h
-    sendToPeerWith peer $ \case
-        NoPairing -> throwError $ "none in progress"
-        OurRequest {} -> throwError $ "waiting for peer"
-        OurRequestConfirm Nothing -> do
-            liftIO $ printMsg $ "Confirmed peer, waiting for updated identity"
-            return (Nothing, OurRequestReady)
-        OurRequestConfirm (Just (AttachIdentity _ _ Nothing)) -> do
-            liftIO $ printMsg $ "Confirmed peer, but verification of received identity failed"
-            return (Nothing, NoPairing)
-        OurRequestConfirm (Just (AttachIdentity _ keys (Just identity))) -> do
-            liftIO $ printMsg $ "Accepted updated identity"
-            flip runReaderT h $ updateLocalState_ $ finalizeAttach identity keys
-            return (Nothing, PairingDone)
-        OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
-        PeerRequest {} -> throwError $ "waiting for peer"
-        PeerRequestConfirm -> do
-            liftIO $ printMsg $ "Accepted new attached device, seding updated identity"
-            owner <- runReaderT mergeSharedIdentity h
-            PeerIdentityFull pid <- peerIdentity peer
-            Just secret <- liftIO $ loadKey $ idKeyIdentity owner
-            liftIO $ do
-                identity <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid)
-                    { iddPrev = [idData pid], iddOwner = Just (idData owner) }
-                skeys <- map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ]
-                return (Just $ PairingAccept $ AttachIdentity identity skeys Nothing, PairingDone)
-        PairingDone -> throwError $ "alredy done"
-        PairingFailed -> throwError $ "alredy failed"
-
-verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity)
-verifyAttachedIdentity sdata = do
-    curid <- lsIdentity . fromStored <$> svcGetLocal
-    secret <- maybe (throwError "failed to load own secret key") return =<<
-        liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid)
-    sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata)
-    return $ do
-        guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) ==
-            iddKeyIdentity (fromStored $ signedData $ fromStored curid)
-        identity <- validateIdentity sdata'
-        guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid]
-        return identity
-
-finalizeAttach :: MonadIO m => UnifiedIdentity -> [ScrubbedBytes] -> Stored LocalState -> m (Stored LocalState)
-finalizeAttach identity skeys slocal = liftIO $ do
-    let owner = finalOwner identity
-        st = storedStorage slocal
-    pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
-    mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- skeys, pub <- pkeys ]
-
-    shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal)
-    wrappedStore st (fromStored slocal)
-        { lsIdentity = idData identity
-        , lsShared = [ shared ]
+        , pairingHookAcceptedResponse = do
+            svcPrint $ "Accepted updated identity"
+
+        , pairingHookAcceptedRequest = do
+            svcPrint $ "Accepted new attached device, seding updated identity"
+
+        , pairingHookVerifyFailed = do
+            svcPrint $ "Failed to verify new identity"
         }
+
+attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m ()
+attachToOwner = pairingRequest @AttachIdentity Proxy
+
+attachAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
+attachAccept = pairingAccept @AttachIdentity Proxy
diff --git a/src/Contact.hs b/src/Contact.hs
index e0f1a74..a4b5cf2 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -86,6 +86,17 @@ instance Storable ContactAccepted where
 instance PairingResult ContactAccepted where
     pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084"
 
+    pairingVerifyResult = return . Just
+
+    pairingFinalizeRequest ContactAccepted = do
+        pid <- asks svcPeerIdentity
+        updateLocalState_ $ finalizeContact pid
+
+    pairingFinalizeResponse = do
+        pid <- asks svcPeerIdentity
+        updateLocalState_ $ finalizeContact pid
+        return ContactAccepted
+
     defaultPairingAttributes _ = PairingAttributes
         { pairingHookRequest = do
             peer <- asks $ svcPeerIdentity
@@ -103,38 +114,26 @@ instance PairingResult ContactAccepted where
             peer <- asks $ svcPeerIdentity
             svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)
 
-        , pairingHookConfirm = \ContactAccepted -> do
+        , pairingHookConfirmedResponse = do
+            svcPrint $ "Contact accepted, waiting for peer confirmation"
+
+        , pairingHookConfirmedRequest = do
             svcPrint $ "Contact confirmed by peer"
-            return $ Just ContactAccepted
 
-        , pairingHookAccept = \ContactAccepted -> return ()
+        , pairingHookAcceptedResponse = do
+            svcPrint $ "Contact accepted"
+
+        , pairingHookAcceptedRequest = do
+            svcPrint $ "Contact accepted"
+
+        , pairingHookVerifyFailed = return ()
         }
 
-contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m ()
-contactRequest _ = pairingRequest @ContactAccepted Proxy
-
-contactAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m ()
-contactAccept printMsg h peer = do
-    sendToPeerWith 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 <- peerIdentity peer
-            liftIO $ printMsg $ "Contact accepted"
-            flip runReaderT h $ updateLocalState_ $ finalizeContact pid
-            return (Nothing, PairingDone)
-        OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
-        PeerRequest {} -> throwError $ "waiting for peer"
-        PeerRequestConfirm -> do
-            PeerIdentityFull pid <- peerIdentity peer
-            liftIO $ printMsg $ "Contact accepted"
-            flip runReaderT h $ updateLocalState_ $ finalizeContact pid
-            return (Just $ PairingAccept ContactAccepted, PairingDone)
-        PairingDone -> throwError $ "alredy done"
-        PairingFailed -> throwError $ "alredy failed"
+contactRequest :: (MonadIO m, MonadError String m) => Peer -> m ()
+contactRequest = pairingRequest @ContactAccepted Proxy
+
+contactAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
+contactAccept = pairingAccept @ContactAccepted Proxy
 
 finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
 finalizeContact identity slocal = liftIO $ do
diff --git a/src/Main.hs b/src/Main.hs
index 1515648..3045f94 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -294,14 +294,11 @@ cmdUpdateIdentity = void $ do
 
 cmdAttach :: Command
 cmdAttach = join $ attachToOwner
-    <$> asks ciPrint
-    <*> (maybe (throwError "no peer selected") return =<< gets csPeer)
+    <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
 
 cmdAttachAccept :: Command
 cmdAttachAccept = join $ attachAccept
-    <$> asks ciPrint
-    <*> asks ciHead
-    <*> (maybe (throwError "no peer selected") return =<< gets csPeer)
+    <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
 
 cmdContacts :: Command
 cmdContacts = do
@@ -315,14 +312,11 @@ cmdContacts = do
 
 cmdContactAdd :: Command
 cmdContactAdd = join $ contactRequest
-    <$> asks ciPrint
-    <*> (maybe (throwError "no peer selected") return =<< gets csPeer)
+    <$> (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)
+    <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
 
 cmdDiscoveryInit :: Command
 cmdDiscoveryInit = void $ do
diff --git a/src/Pairing.hs b/src/Pairing.hs
index d2f4b31..a30615a 100644
--- a/src/Pairing.hs
+++ b/src/Pairing.hs
@@ -5,6 +5,7 @@ module Pairing (
     PairingResult(..),
 
     pairingRequest,
+    pairingAccept,
 ) where
 
 import Control.Monad.Except
@@ -35,7 +36,7 @@ data PairingService a = PairingRequest RefDigest
 
 data PairingState a = NoPairing
                     | OurRequest Bytes
-                    | OurRequestConfirm (Maybe a)
+                    | OurRequestConfirm (Maybe (PairingVerifiedResult a))
                     | OurRequestReady
                     | PeerRequest Bytes RefDigest
                     | PeerRequestConfirm
@@ -47,12 +48,21 @@ data PairingAttributes a = PairingAttributes
     , pairingHookResponse :: String -> ServiceHandler (PairingService a) ()
     , pairingHookRequestNonce :: String -> ServiceHandler (PairingService a) ()
     , pairingHookRequestNonceFailed :: ServiceHandler (PairingService a) ()
-    , pairingHookConfirm :: a -> ServiceHandler (PairingService a) (Maybe a)
-    , pairingHookAccept :: a -> ServiceHandler (PairingService a) ()
+    , pairingHookConfirmedResponse :: ServiceHandler (PairingService a) ()
+    , pairingHookConfirmedRequest :: ServiceHandler (PairingService a) ()
+    , pairingHookAcceptedResponse :: ServiceHandler (PairingService a) ()
+    , pairingHookAcceptedRequest :: ServiceHandler (PairingService a) ()
+    , pairingHookVerifyFailed :: ServiceHandler (PairingService a) ()
     }
 
 class (Typeable a, Storable a) => PairingResult a where
+    type PairingVerifiedResult a :: *
+    type PairingVerifiedResult a = a
+
     pairingServiceID :: proxy a -> ServiceID
+    pairingVerifyResult :: a -> ServiceHandler (PairingService a) (Maybe (PairingVerifiedResult a))
+    pairingFinalizeRequest :: PairingVerifiedResult a -> ServiceHandler (PairingService a) ()
+    pairingFinalizeResponse :: ServiceHandler (PairingService a) a
     defaultPairingAttributes :: proxy (PairingService a) -> PairingAttributes a
 
 
@@ -110,20 +120,29 @@ instance PairingResult a => Service (PairingService a) where
             replyPacket PairingDecline
 
         (OurRequestConfirm _, PairingAccept x) -> do
-            hook <- asks $ pairingHookConfirm . svcAttributes
-            (svcSet . OurRequestConfirm =<< hook x) `catchError` \_ -> do
-                svcSet $ PairingFailed
-                replyPacket PairingDecline
+            flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do
+                pairingVerifyResult x >>= \case
+                    Just x' -> do
+                        join $ asks $ pairingHookConfirmedRequest . svcAttributes
+                        svcSet $ OurRequestConfirm (Just x')
+                    Nothing -> do
+                        join $ asks $ pairingHookVerifyFailed . svcAttributes
+                        throwError ""
 
         (OurRequestConfirm _, _) -> do
             svcSet $ PairingFailed
             replyPacket PairingDecline
 
         (OurRequestReady, PairingAccept x) -> do
-            hook <- asks $ pairingHookAccept . svcAttributes
-            hook x `catchError` \_ -> do
-                svcSet $ PairingFailed
-                replyPacket PairingDecline
+            flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do
+                pairingVerifyResult x >>= \case
+                    Just x' -> do
+                        pairingFinalizeRequest x'
+                        join $ asks $ pairingHookAcceptedResponse . svcAttributes
+                        svcSet $ PairingDone
+                    Nothing -> do
+                        join $ asks $ pairingHookVerifyFailed . svcAttributes
+                        throwError ""
         (OurRequestReady, _) -> do
             svcSet $ PairingFailed
             replyPacket PairingDecline
@@ -173,4 +192,25 @@ pairingRequest _ peer = do
         _ -> throwError "incomplete peer identity"
     sendToPeerWith @(PairingService a) peer $ \case
         NoPairing -> return (Just $ PairingRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce)
-        _ -> throwError "alredy in progress"
+        _ -> throwError "already in progress"
+
+pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()
+pairingAccept _ peer = runPeerService @(PairingService a) peer $ do
+    svcGet >>= \case
+        NoPairing -> throwError $ "none in progress"
+        OurRequest {} -> throwError $ "waiting for peer"
+        OurRequestConfirm Nothing -> do
+            join $ asks $ pairingHookConfirmedResponse . svcAttributes
+            svcSet OurRequestReady
+        OurRequestConfirm (Just verified) -> do
+            join $ asks $ pairingHookAcceptedResponse . svcAttributes
+            pairingFinalizeRequest verified
+            svcSet PairingDone
+        OurRequestReady -> throwError $ "already accepted, waiting for peer"
+        PeerRequest {} -> throwError $ "waiting for peer"
+        PeerRequestConfirm -> do
+            join $ asks $ pairingHookAcceptedRequest . svcAttributes
+            replyPacket . PairingAccept =<< pairingFinalizeResponse
+            svcSet PairingDone
+        PairingDone -> throwError $ "already done"
+        PairingFailed -> throwError $ "already failed"