Pairing: use service attributes for hooks

3 files changed, 77 insertions, 62 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
index adb9d2f..89ed4bb 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -36,40 +36,41 @@ instance Storable AttachIdentity where
 
 instance PairingResult AttachIdentity where
     pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
-
-    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)
-
-    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"
+    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)
+
+        , 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"
+        }
 
 attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m ()
 attachToOwner _ = pairingRequest @AttachIdentity Proxy
diff --git a/src/Contact.hs b/src/Contact.hs
index 01bd49d..9accc4d 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -86,27 +86,29 @@ instance Storable ContactAccepted where
 instance PairingResult ContactAccepted where
     pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084"
 
-    pairingHookRequest = do
-        peer <- asks $ svcPeerIdentity
-        svcPrint $ "Contact pairing from " ++ T.unpack (displayIdentity peer) ++ " initiated"
+    defaultPairingAttributes _ = PairingAttributes
+        { pairingHookRequest = do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Contact pairing from " ++ T.unpack (displayIdentity peer) ++ " initiated"
 
-    pairingHookResponse confirm = do
-        peer <- asks $ svcPeerIdentity
-        svcPrint $ "Confirm contact " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
+        , pairingHookResponse = \confirm -> do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Confirm contact " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
 
-    pairingHookRequestNonce confirm = do
-        peer <- asks $ svcPeerIdentity
-        svcPrint $ "Contact request from " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
+        , pairingHookRequestNonce = \confirm -> do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Contact request from " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
 
-    pairingHookRequestNonceFailed = do
-        peer <- asks $ svcPeerIdentity
-        svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)
+        , pairingHookRequestNonceFailed = do
+            peer <- asks $ svcPeerIdentity
+            svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)
 
-    pairingHookConfirm ContactAccepted = do
-        svcPrint $ "Contact confirmed by peer"
-        return $ Just ContactAccepted
+        , pairingHookConfirm = \ContactAccepted -> do
+            svcPrint $ "Contact confirmed by peer"
+            return $ Just ContactAccepted
 
-    pairingHookAccept ContactAccepted = return ()
+        , pairingHookAccept = \ContactAccepted -> return ()
+        }
 
 contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Peer -> m ()
 contactRequest _ = pairingRequest @ContactAccepted Proxy
diff --git a/src/Pairing.hs b/src/Pairing.hs
index 6407afa..d2f4b31 100644
--- a/src/Pairing.hs
+++ b/src/Pairing.hs
@@ -1,6 +1,7 @@
 module Pairing (
     PairingService(..),
     PairingState(..),
+    PairingAttributes(..),
     PairingResult(..),
 
     pairingRequest,
@@ -41,14 +42,18 @@ data PairingState a = NoPairing
                     | PairingDone
                     | PairingFailed
 
+data PairingAttributes a = PairingAttributes
+    { pairingHookRequest :: ServiceHandler (PairingService a) ()
+    , 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) ()
+    }
+
 class (Typeable a, Storable a) => PairingResult a where
     pairingServiceID :: proxy a -> ServiceID
-    pairingHookRequest :: ServiceHandler (PairingService a) ()
-    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) ()
+    defaultPairingAttributes :: proxy (PairingService a) -> PairingAttributes a
 
 
 instance Storable a => Storable (PairingService a) where
@@ -78,12 +83,15 @@ instance Storable a => Storable (PairingService a) where
 instance PairingResult a => Service (PairingService a) where
     serviceID _ = pairingServiceID @a Proxy
 
+    type ServiceAttributes (PairingService a) = PairingAttributes a
+    defaultServiceAttributes = defaultPairingAttributes
+
     type ServiceState (PairingService a) = PairingState a
     emptyServiceState _ = NoPairing
 
     serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
         (NoPairing, PairingRequest confirm) -> do
-            pairingHookRequest
+            join $ asks $ pairingHookRequest . svcAttributes
             nonce <- liftIO $ getRandomBytes 32
             svcSet $ PeerRequest nonce confirm
             replyPacket $ PairingResponse nonce
@@ -93,7 +101,8 @@ instance PairingResult a => Service (PairingService a) where
             peer <- asks $ svcPeerIdentity
             self <- maybe (throwError "failed to validate own identity") return .
                 validateIdentity . lsIdentity . fromStored =<< svcGetLocal
-            pairingHookResponse $ confirmationNumber $ nonceDigest self peer nonce pnonce
+            hook <- asks $ pairingHookResponse . svcAttributes
+            hook $ confirmationNumber $ nonceDigest self peer nonce pnonce
             svcSet $ OurRequestConfirm Nothing
             replyPacket $ PairingRequestNonce nonce
         (OurRequest _, _) -> do
@@ -101,7 +110,8 @@ instance PairingResult a => Service (PairingService a) where
             replyPacket PairingDecline
 
         (OurRequestConfirm _, PairingAccept x) -> do
-            (svcSet . OurRequestConfirm =<< pairingHookConfirm x) `catchError` \_ -> do
+            hook <- asks $ pairingHookConfirm . svcAttributes
+            (svcSet . OurRequestConfirm =<< hook x) `catchError` \_ -> do
                 svcSet $ PairingFailed
                 replyPacket PairingDecline
 
@@ -110,7 +120,8 @@ instance PairingResult a => Service (PairingService a) where
             replyPacket PairingDecline
 
         (OurRequestReady, PairingAccept x) -> do
-            pairingHookAccept x `catchError` \_ -> do
+            hook <- asks $ pairingHookAccept . svcAttributes
+            hook x `catchError` \_ -> do
                 svcSet $ PairingFailed
                 replyPacket PairingDecline
         (OurRequestReady, _) -> do
@@ -122,9 +133,10 @@ instance PairingResult a => Service (PairingService a) where
             self <- maybe (throwError "failed to verify own identity") return .
                 validateIdentity . lsIdentity . fromStored =<< svcGetLocal
             if dgst == nonceDigest peer self pnonce BA.empty
-               then do pairingHookRequestNonce $ confirmationNumber $ nonceDigest peer self pnonce nonce
+               then do hook <- asks $ pairingHookRequestNonce . svcAttributes
+                       hook $ confirmationNumber $ nonceDigest peer self pnonce nonce
                        svcSet PeerRequestConfirm
-               else do pairingHookRequestNonceFailed
+               else do join $ asks $ pairingHookRequestNonceFailed . svcAttributes
                        svcSet PairingFailed
                        replyPacket PairingDecline
         (PeerRequest _ _, _) -> do