diff options
| -rw-r--r-- | src/Attach.hs | 69 | ||||
| -rw-r--r-- | src/Contact.hs | 34 | ||||
| -rw-r--r-- | src/Pairing.hs | 36 |
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 |