summaryrefslogtreecommitdiff
path: root/src/Erebos/Pairing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Pairing.hs')
-rw-r--r--src/Erebos/Pairing.hs68
1 files changed, 35 insertions, 33 deletions
diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs
index 2166e71..e3ebf2b 100644
--- a/src/Erebos/Pairing.hs
+++ b/src/Erebos/Pairing.hs
@@ -17,9 +17,10 @@ import Control.Monad.Reader
import Crypto.Random
import Data.Bits
-import Data.ByteArray (Bytes, convert)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString.Char8 as BC
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BC
import Data.Kind
import Data.Maybe
import Data.Typeable
@@ -27,28 +28,29 @@ import Data.Word
import Erebos.Identity
import Erebos.Network
+import Erebos.Object
import Erebos.PubKey
import Erebos.Service
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest
- | PairingResponse Bytes
- | PairingRequestNonce Bytes
+ | PairingResponse ByteString
+ | PairingRequestNonce ByteString
| PairingAccept a
| PairingReject
data PairingState a = NoPairing
- | OurRequest UnifiedIdentity UnifiedIdentity Bytes
+ | OurRequest UnifiedIdentity UnifiedIdentity ByteString
| OurRequestConfirm (Maybe (PairingVerifiedResult a))
| OurRequestReady
- | PeerRequest UnifiedIdentity UnifiedIdentity Bytes RefDigest
+ | PeerRequest UnifiedIdentity UnifiedIdentity ByteString RefDigest
| PeerRequestConfirm
| PairingDone
data PairingFailureReason a = PairingUserRejected
| PairingUnexpectedMessage (PairingState a) (PairingService a)
- | PairingFailedOther String
+ | PairingFailedOther ErebosError
data PairingAttributes a = PairingAttributes
{ pairingHookRequest :: ServiceHandler (PairingService a) ()
@@ -87,7 +89,7 @@ instance Storable a => Storable (PairingService a) where
load' = do
res <- loadRec $ do
- (req :: Maybe Bytes) <- loadMbBinary "request"
+ (req :: Maybe ByteString) <- loadMbBinary "request"
idReq <- loadMbRef "id-req"
idRsp <- loadMbRef "id-rsp"
rsp <- loadMbBinary "response"
@@ -115,16 +117,16 @@ instance PairingResult a => Service (PairingService a) where
serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
(NoPairing, PairingRequest pdata sdata confirm) -> do
- self <- maybe (throwError "failed to validate received identity") return $ validateIdentity sdata
- self' <- maybe (throwError "failed to validate own identity") return .
+ self <- maybe (throwOtherError "failed to validate received identity") return $ validateIdentity sdata
+ self' <- maybe (throwOtherError "failed to validate own identity") return .
validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal
when (not $ self `sameIdentity` self') $ do
- throwError "pairing request to different identity"
+ throwOtherError "pairing request to different identity"
- peer <- maybe (throwError "failed to validate received peer identity") return $ validateIdentity pdata
+ peer <- maybe (throwOtherError "failed to validate received peer identity") return $ validateIdentity pdata
peer' <- asks $ svcPeerIdentity
when (not $ peer `sameIdentity` peer') $ do
- throwError "pairing request from different identity"
+ throwOtherError "pairing request from different identity"
join $ asks $ pairingHookRequest . svcAttributes
nonce <- liftIO $ getRandomBytes 32
@@ -166,11 +168,11 @@ instance PairingResult a => Service (PairingService a) where
svcSet $ PairingDone
Nothing -> do
join $ asks $ pairingHookVerifyFailed . svcAttributes
- throwError ""
+ throwOtherError ""
x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x
(PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do
- if dgst == nonceDigest peer self pnonce BA.empty
+ if dgst == nonceDigest peer self pnonce BS.empty
then do hook <- asks $ pairingHookRequestNonce . svcAttributes
hook $ confirmationNumber $ nonceDigest peer self pnonce nonce
svcSet PeerRequestConfirm
@@ -187,12 +189,12 @@ reject reason = do
replyPacket PairingReject
-nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
+nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> ByteString -> ByteString -> RefDigest
nonceDigest idReq idRsp nonceReq nonceRsp = hashToRefDigest $ serializeObject $ Rec
[ (BC.pack "id-req", RecRef $ storedRef $ idData idReq)
, (BC.pack "id-rsp", RecRef $ storedRef $ idData idRsp)
- , (BC.pack "nonce-req", RecBinary $ convert nonceReq)
- , (BC.pack "nonce-rsp", RecBinary $ convert nonceRsp)
+ , (BC.pack "nonce-req", RecBinary nonceReq)
+ , (BC.pack "nonce-rsp", RecBinary nonceRsp)
]
confirmationNumber :: RefDigest -> String
@@ -203,22 +205,22 @@ confirmationNumber dgst =
_ -> ""
where len = 6
-pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()
+pairingRequest :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m ()
pairingRequest _ peer = do
self <- liftIO $ serverIdentity $ peerServer peer
nonce <- liftIO $ getRandomBytes 32
pid <- peerIdentity peer >>= \case
PeerIdentityFull pid -> return pid
- _ -> throwError "incomplete peer identity"
+ _ -> throwOtherError "incomplete peer identity"
sendToPeerWith @(PairingService a) peer $ \case
- NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce)
- _ -> throwError "already in progress"
+ NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BS.empty), OurRequest self pid nonce)
+ _ -> throwOtherError "already in progress"
-pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()
+pairingAccept :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m ()
pairingAccept _ peer = runPeerService @(PairingService a) peer $ do
svcGet >>= \case
- NoPairing -> throwError $ "none in progress"
- OurRequest {} -> throwError $ "waiting for peer"
+ NoPairing -> throwOtherError $ "none in progress"
+ OurRequest {} -> throwOtherError $ "waiting for peer"
OurRequestConfirm Nothing -> do
join $ asks $ pairingHookConfirmedResponse . svcAttributes
svcSet OurRequestReady
@@ -226,17 +228,17 @@ pairingAccept _ peer = runPeerService @(PairingService a) peer $ do
join $ asks $ pairingHookAcceptedResponse . svcAttributes
pairingFinalizeRequest verified
svcSet PairingDone
- OurRequestReady -> throwError $ "already accepted, waiting for peer"
- PeerRequest {} -> throwError $ "waiting for peer"
+ OurRequestReady -> throwOtherError $ "already accepted, waiting for peer"
+ PeerRequest {} -> throwOtherError $ "waiting for peer"
PeerRequestConfirm -> do
join $ asks $ pairingHookAcceptedRequest . svcAttributes
replyPacket . PairingAccept =<< pairingFinalizeResponse
svcSet PairingDone
- PairingDone -> throwError $ "already done"
+ PairingDone -> throwOtherError $ "already done"
-pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m ()
+pairingReject :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m ()
pairingReject _ peer = runPeerService @(PairingService a) peer $ do
svcGet >>= \case
- NoPairing -> throwError $ "none in progress"
- PairingDone -> throwError $ "already done"
+ NoPairing -> throwOtherError $ "none in progress"
+ PairingDone -> throwOtherError $ "already done"
_ -> reject PairingUserRejected
generated by cgit v1.2.3 (git 2.25.1) at 2025-05-11 13:08:26 +0000