summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Attach.hs13
-rw-r--r--src/Contact.hs10
-rw-r--r--src/Main.hs10
-rw-r--r--src/Pairing.hs53
4 files changed, 62 insertions, 24 deletions
diff --git a/src/Attach.hs b/src/Attach.hs
index c220e14..90c9900 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -1,6 +1,8 @@
module Attach (
AttachService,
- attachToOwner, attachAccept,
+ attachToOwner,
+ attachAccept,
+ attachReject,
) where
import Control.Monad.Except
@@ -103,6 +105,12 @@ instance PairingResult AttachIdentity where
, pairingHookVerifyFailed = do
svcPrint $ "Failed to verify new identity"
+
+ , pairingHookRejected = do
+ svcPrint $ "Attachment rejected by peer"
+
+ , pairingHookFailed = do
+ svcPrint $ "Attachement failed"
}
attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m ()
@@ -110,3 +118,6 @@ attachToOwner = pairingRequest @AttachIdentity Proxy
attachAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
attachAccept = pairingAccept @AttachIdentity Proxy
+
+attachReject :: (MonadIO m, MonadError String m) => Peer -> m ()
+attachReject = pairingReject @AttachIdentity Proxy
diff --git a/src/Contact.hs b/src/Contact.hs
index a4b5cf2..73a179f 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -5,6 +5,7 @@ module Contact (
ContactService,
contactRequest,
contactAccept,
+ contactReject,
) where
import Control.Arrow
@@ -127,6 +128,12 @@ instance PairingResult ContactAccepted where
svcPrint $ "Contact accepted"
, pairingHookVerifyFailed = return ()
+
+ , pairingHookRejected = do
+ svcPrint $ "Contact rejected by peer"
+
+ , pairingHookFailed = do
+ svcPrint $ "Contact failed"
}
contactRequest :: (MonadIO m, MonadError String m) => Peer -> m ()
@@ -135,6 +142,9 @@ contactRequest = pairingRequest @ContactAccepted Proxy
contactAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
contactAccept = pairingAccept @ContactAccepted Proxy
+contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
+contactReject = pairingReject @ContactAccepted Proxy
+
finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
finalizeContact identity slocal = liftIO $ do
let st = storedStorage slocal
diff --git a/src/Main.hs b/src/Main.hs
index 3045f94..2c56a00 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -230,9 +230,11 @@ commands =
, ("update-identity", cmdUpdateIdentity)
, ("attach", cmdAttach)
, ("attach-accept", cmdAttachAccept)
+ , ("attach-reject", cmdAttachReject)
, ("contacts", cmdContacts)
, ("contact-add", cmdContactAdd)
, ("contact-accept", cmdContactAccept)
+ , ("contact-reject", cmdContactReject)
, ("discovery-init", cmdDiscoveryInit)
, ("discovery", cmdDiscovery)
, ("ice-create", cmdIceCreate)
@@ -300,6 +302,10 @@ cmdAttachAccept :: Command
cmdAttachAccept = join $ attachAccept
<$> (maybe (throwError "no peer selected") return =<< gets csPeer)
+cmdAttachReject :: Command
+cmdAttachReject = join $ attachReject
+ <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
cmdContacts :: Command
cmdContacts = do
args <- words <$> asks ciLine
@@ -318,6 +324,10 @@ cmdContactAccept :: Command
cmdContactAccept = join $ contactAccept
<$> (maybe (throwError "no peer selected") return =<< gets csPeer)
+cmdContactReject :: Command
+cmdContactReject = join $ contactReject
+ <$> (maybe (throwError "no peer selected") return =<< gets csPeer)
+
cmdDiscoveryInit :: Command
cmdDiscoveryInit = void $ do
server <- asks ciServer
diff --git a/src/Pairing.hs b/src/Pairing.hs
index a30615a..2c3f2ff 100644
--- a/src/Pairing.hs
+++ b/src/Pairing.hs
@@ -6,6 +6,7 @@ module Pairing (
pairingRequest,
pairingAccept,
+ pairingReject,
) where
import Control.Monad.Except
@@ -41,7 +42,6 @@ data PairingState a = NoPairing
| PeerRequest Bytes RefDigest
| PeerRequestConfirm
| PairingDone
- | PairingFailed
data PairingAttributes a = PairingAttributes
{ pairingHookRequest :: ServiceHandler (PairingService a) ()
@@ -53,6 +53,8 @@ data PairingAttributes a = PairingAttributes
, pairingHookAcceptedResponse :: ServiceHandler (PairingService a) ()
, pairingHookAcceptedRequest :: ServiceHandler (PairingService a) ()
, pairingHookVerifyFailed :: ServiceHandler (PairingService a) ()
+ , pairingHookRejected :: ServiceHandler (PairingService a) ()
+ , pairingHookFailed :: ServiceHandler (PairingService a) ()
}
class (Typeable a, Storable a) => PairingResult a where
@@ -107,6 +109,11 @@ instance PairingResult a => Service (PairingService a) where
replyPacket $ PairingResponse nonce
(NoPairing, _) -> return ()
+ (PairingDone, _) -> return ()
+ (_, PairingDecline) -> do
+ join $ asks $ pairingHookRejected . svcAttributes
+ svcSet NoPairing
+
(OurRequest nonce, PairingResponse pnonce) -> do
peer <- asks $ svcPeerIdentity
self <- maybe (throwError "failed to validate own identity") return .
@@ -115,26 +122,23 @@ instance PairingResult a => Service (PairingService a) where
hook $ confirmationNumber $ nonceDigest self peer nonce pnonce
svcSet $ OurRequestConfirm Nothing
replyPacket $ PairingRequestNonce nonce
- (OurRequest _, _) -> do
- svcSet $ PairingFailed
- replyPacket PairingDecline
+ (OurRequest _, _) -> reject
(OurRequestConfirm _, PairingAccept x) -> do
- flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do
+ flip catchError (const reject) $ do
pairingVerifyResult x >>= \case
Just x' -> do
join $ asks $ pairingHookConfirmedRequest . svcAttributes
svcSet $ OurRequestConfirm (Just x')
Nothing -> do
join $ asks $ pairingHookVerifyFailed . svcAttributes
- throwError ""
+ svcSet NoPairing
+ replyPacket PairingDecline
- (OurRequestConfirm _, _) -> do
- svcSet $ PairingFailed
- replyPacket PairingDecline
+ (OurRequestConfirm _, _) -> reject
(OurRequestReady, PairingAccept x) -> do
- flip catchError (\_ -> svcSet PairingFailed >> replyPacket PairingDecline) $ do
+ flip catchError (const reject) $ do
pairingVerifyResult x >>= \case
Just x' -> do
pairingFinalizeRequest x'
@@ -143,9 +147,7 @@ instance PairingResult a => Service (PairingService a) where
Nothing -> do
join $ asks $ pairingHookVerifyFailed . svcAttributes
throwError ""
- (OurRequestReady, _) -> do
- svcSet $ PairingFailed
- replyPacket PairingDecline
+ (OurRequestReady, _) -> reject
(PeerRequest nonce dgst, PairingRequestNonce pnonce) -> do
peer <- asks $ svcPeerIdentity
@@ -156,17 +158,16 @@ instance PairingResult a => Service (PairingService a) where
hook $ confirmationNumber $ nonceDigest peer self pnonce nonce
svcSet PeerRequestConfirm
else do join $ asks $ pairingHookRequestNonceFailed . svcAttributes
- svcSet PairingFailed
+ svcSet NoPairing
replyPacket PairingDecline
- (PeerRequest _ _, _) -> do
- svcSet $ PairingFailed
- replyPacket PairingDecline
- (PeerRequestConfirm, _) -> do
- svcSet $ PairingFailed
- replyPacket PairingDecline
+ (PeerRequest _ _, _) -> reject
+ (PeerRequestConfirm, _) -> reject
- (PairingDone, _) -> return ()
- (PairingFailed, _) -> return ()
+reject :: PairingResult a => ServiceHandler (PairingService a) ()
+reject = do
+ join $ asks $ pairingHookFailed . svcAttributes
+ svcSet NoPairing
+ replyPacket PairingDecline
nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
@@ -213,4 +214,10 @@ pairingAccept _ peer = runPeerService @(PairingService a) peer $ do
replyPacket . PairingAccept =<< pairingFinalizeResponse
svcSet PairingDone
PairingDone -> throwError $ "already done"
- PairingFailed -> throwError $ "already failed"
+
+pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()
+pairingReject _ peer = runPeerService @(PairingService a) peer $ do
+ svcGet >>= \case
+ NoPairing -> throwError $ "none in progress"
+ PairingDone -> throwError $ "already done"
+ _ -> reject