summaryrefslogtreecommitdiff
path: root/src/Pairing.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2021-12-19 22:59:01 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2021-12-19 23:18:05 +0100
commit8416b3e959fd0f6ade7c2b61a6caea681ee03e15 (patch)
tree5a32fadd89efa165dd71c0f0f1ee23fdf06bab03 /src/Pairing.hs
parent070122683d0c9a11f9221ede93df0590bc28494d (diff)
Pairing: use service attributes for hooks
Diffstat (limited to 'src/Pairing.hs')
-rw-r--r--src/Pairing.hs36
1 files changed, 24 insertions, 12 deletions
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