From 8416b3e959fd0f6ade7c2b61a6caea681ee03e15 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 19 Dec 2021 22:59:01 +0100
Subject: Pairing: use service attributes for hooks

---
 src/Attach.hs | 69 ++++++++++++++++++++++++++++++-----------------------------
 1 file changed, 35 insertions(+), 34 deletions(-)

(limited to 'src/Attach.hs')

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
-- 
cgit v1.2.3