summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs69
-rw-r--r--src/Contact.hs34
-rw-r--r--src/Pairing.hs36
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-20 14:30:11 +0000