summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2020-08-08 20:11:59 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2020-08-09 21:44:00 +0200
commit3caea2bfbbddf2b3d872eb16e15877194bdfe0d6 (patch)
tree418cb1398c6254679b0d8be74e95b35c330365da /src
parenta4437f0479a721aeebac305e403b88b18a5f7d5f (diff)
Move pairing logic to separate module
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs218
-rw-r--r--src/Pairing.hs163
2 files changed, 227 insertions, 154 deletions
diff --git a/src/Attach.hs b/src/Attach.hs
index 95f0a67..5acc608 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -6,165 +6,92 @@ module Attach (
import Control.Monad.Except
import Control.Monad.Reader
-import Crypto.Random
-
-import Data.Bits
-import Data.ByteArray (Bytes, ScrubbedBytes, convert)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString.Char8 as BC
+import Data.ByteArray (ScrubbedBytes)
import Data.Maybe
+import Data.Proxy
import qualified Data.Text as T
-import Data.Word
import Identity
import Network
+import Pairing
import PubKey
import Service
import State
import Storage
import Storage.Key
-data AttachService = AttachRequest RefDigest
- | AttachResponse Bytes
- | AttachRequestNonce Bytes
- | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
- | AttachDecline
-
-data AttachState = NoAttach
- | OurRequest Bytes
- | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes]))
- | OurRequestReady
- | PeerRequest Bytes RefDigest
- | PeerRequestConfirm
- | AttachDone
- | AttachFailed
-
-instance Storable AttachService where
- store' at = storeRec $ do
- case at of
- AttachRequest x -> storeBinary "request" x
- AttachResponse x -> storeBinary "response" x
- AttachRequestNonce x -> storeBinary "reqnonce" x
- AttachIdentity x keys -> do
- storeRef "identity" x
- mapM_ (storeBinary "skey") keys
- AttachDecline -> storeText "decline" ""
-
- load' = loadRec $ do
- (req :: Maybe Bytes) <- loadMbBinary "request"
- rsp <- loadMbBinary "response"
- rnonce <- loadMbBinary "reqnonce"
- aid <- loadMbRef "identity"
- skeys <- loadBinaries "skey"
- (decline :: Maybe T.Text) <- loadMbText "decline"
- let res = catMaybes
- [ AttachRequest <$> (refDigestFromByteString =<< req)
- , AttachResponse <$> rsp
- , AttachRequestNonce <$> rnonce
- , AttachIdentity <$> aid <*> pure skeys
- , const AttachDecline <$> decline
- ]
- case res of
- x:_ -> return x
- [] -> throwError "invalid attach stange"
-
-instance Service AttachService where
- serviceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
-
- type ServiceState AttachService = AttachState
- emptyServiceState _ = NoAttach
-
- serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
- (NoAttach, AttachRequest confirm) -> do
- peer <- asks $ svcPeer
- svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
- nonce <- liftIO $ getRandomBytes 32
- svcSet $ PeerRequest nonce confirm
- replyPacket $ AttachResponse nonce
- (NoAttach, _) -> return ()
-
- (OurRequest nonce, AttachResponse pnonce) -> do
- peer <- asks $ svcPeer
- self <- maybe (throwError "failed to verify own identity") return .
- validateIdentity . lsIdentity . fromStored =<< svcGetLocal
- svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce)
- svcSet $ OurRequestConfirm Nothing
- replyPacket $ AttachRequestNonce nonce
- (OurRequest _, _) -> do
- svcSet $ AttachFailed
- replyPacket AttachDecline
-
- (OurRequestConfirm _, AttachIdentity sdata keys) -> do
- verifyAttachedIdentity sdata >>= \case
- Just owner -> do
- svcPrint $ "Attachment confirmed by peer"
- svcSet $ OurRequestConfirm $ Just (owner, keys)
- Nothing -> do
- svcPrint $ "Failed to verify new identity"
- svcSet $ AttachFailed
- replyPacket AttachDecline
- (OurRequestConfirm _, _) -> do
- svcSet $ AttachFailed
- replyPacket AttachDecline
-
- (OurRequestReady, 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"
- svcSet $ AttachFailed
- replyPacket AttachDecline
- (OurRequestReady, _) -> do
- svcSet $ AttachFailed
- replyPacket AttachDecline
-
- (PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do
- peer <- asks $ svcPeer
- self <- maybe (throwError "failed to verify own identity") return .
- validateIdentity . lsIdentity . fromStored =<< svcGetLocal
- if dgst == nonceDigest peer self pnonce BA.empty
- then do svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest peer self pnonce nonce)
- svcSet PeerRequestConfirm
- else do svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer)
- svcSet AttachFailed
- replyPacket AttachDecline
- (PeerRequest _ _, _) -> do
- svcSet $ AttachFailed
- replyPacket AttachDecline
- (PeerRequestConfirm, _) -> do
- svcSet $ AttachFailed
- replyPacket AttachDecline
-
- (AttachDone, _) -> return ()
- (AttachFailed, _) -> return ()
+type AttachService = PairingService AttachIdentity
+
+data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] (Maybe UnifiedIdentity)
+
+instance Storable AttachIdentity where
+ store' (AttachIdentity x keys _) = storeRec $ do
+ storeRef "identity" x
+ mapM_ (storeBinary "skey") keys
+
+ load' = loadRec $ AttachIdentity
+ <$> loadRef "identity"
+ <*> loadBinaries "skey"
+ <*> pure Nothing
+
+instance PairingResult AttachIdentity where
+ pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
+
+ pairingHookRequest = do
+ peer <- asks $ svcPeer
+ svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
+
+ pairingHookResponse confirm = do
+ peer <- asks $ svcPeer
+ svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm
+
+ pairingHookRequestNonce confirm = do
+ peer <- asks $ svcPeer
+ svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm
+
+ pairingHookRequestNonceFailed = do
+ peer <- asks $ svcPeer
+ 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 ()) -> UnifiedIdentity -> Peer -> m ()
-attachToOwner _ self peer = do
- nonce <- liftIO $ getRandomBytes 32
- pid <- case peerIdentity peer of
- PeerIdentityFull pid -> return pid
- _ -> throwError "incomplete peer identity"
- sendToPeerWith self peer $ \case
- NoAttach -> return (Just $ AttachRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce)
- _ -> throwError "alredy in progress"
+attachToOwner _ = pairingRequest @AttachIdentity Proxy
attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m ()
attachAccept printMsg h peer = do
let st = refStorage $ headRef h
self = headLocalIdentity h
sendToPeerWith self peer $ \case
- NoAttach -> throwError $ "none in progress"
+ NoPairing -> throwError $ "none in progress"
OurRequest {} -> throwError $ "waiting for peer"
OurRequestConfirm Nothing -> do
liftIO $ printMsg $ "Confirmed peer, waiting for updated identity"
return (Nothing, OurRequestReady)
- OurRequestConfirm (Just (identity, keys)) -> do
+ OurRequestConfirm (Just (AttachIdentity _ _ Nothing)) -> do
+ liftIO $ printMsg $ "Confirmed peer, but verification of received identity failed"
+ return (Nothing, NoPairing)
+ OurRequestConfirm (Just (AttachIdentity _ keys (Just identity))) -> do
liftIO $ do
printMsg $ "Accepted updated identity"
updateLocalState_ h $ finalizeAttach identity keys
- return (Nothing, AttachDone)
+ return (Nothing, PairingDone)
OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
PeerRequest {} -> throwError $ "waiting for peer"
PeerRequestConfirm -> do
@@ -176,25 +103,9 @@ attachAccept printMsg h peer = do
identity <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid)
{ iddPrev = [idData pid], iddOwner = Just (idData owner) }
skeys <- map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ]
- return (Just $ AttachIdentity identity skeys, NoAttach)
- AttachDone -> throwError $ "alredy done"
- AttachFailed -> throwError $ "alredy failed"
-
-
-nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
-nonceDigest id1 id2 nonce1 nonce2 = hashToRefDigest $ serializeObject $ Rec
- [ (BC.pack "id", RecRef $ storedRef $ idData id1)
- , (BC.pack "id", RecRef $ storedRef $ idData id2)
- , (BC.pack "nonce", RecBinary $ convert nonce1)
- , (BC.pack "nonce", RecBinary $ convert nonce2)
- ]
-
-confirmationNumber :: RefDigest -> String
-confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: [Word32]
- str = show $ (a .|. (b `shift` 8) .|. (c `shift` 16) .|. (d `shift` 24)) `mod` (10 ^ len)
- in replicate (len - length str) '0' ++ str
- where len = 6
-
+ return (Just $ PairingAccept $ AttachIdentity identity skeys Nothing, PairingDone)
+ PairingDone -> throwError $ "alredy done"
+ PairingFailed -> throwError $ "alredy failed"
verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity)
verifyAttachedIdentity sdata = do
@@ -209,7 +120,6 @@ verifyAttachedIdentity sdata = do
guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid]
return identity
-
finalizeAttach :: MonadIO m => UnifiedIdentity -> [ScrubbedBytes] -> Stored LocalState -> m (Stored LocalState)
finalizeAttach identity skeys slocal = liftIO $ do
let owner = finalOwner identity
@@ -221,4 +131,4 @@ finalizeAttach identity skeys slocal = liftIO $ do
wrappedStore st (fromStored slocal)
{ lsIdentity = idData identity
, lsShared = [ shared ]
- }
+ }
diff --git a/src/Pairing.hs b/src/Pairing.hs
new file mode 100644
index 0000000..a0a19b3
--- /dev/null
+++ b/src/Pairing.hs
@@ -0,0 +1,163 @@
+module Pairing (
+ PairingService(..),
+ PairingState(..),
+ PairingResult(..),
+
+ pairingRequest,
+) where
+
+import Control.Monad.Except
+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.Maybe
+import qualified Data.Text as T
+import Data.Typeable
+import Data.Word
+
+import Identity
+import Network
+import Service
+import State
+import Storage
+
+data PairingService a = PairingRequest RefDigest
+ | PairingResponse Bytes
+ | PairingRequestNonce Bytes
+ | PairingAccept a
+ | PairingDecline
+
+data PairingState a = NoPairing
+ | OurRequest Bytes
+ | OurRequestConfirm (Maybe a)
+ | OurRequestReady
+ | PeerRequest Bytes RefDigest
+ | PeerRequestConfirm
+ | PairingDone
+ | PairingFailed
+
+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) ()
+
+
+instance Storable a => Storable (PairingService a) where
+ store' (PairingRequest x) = storeRec $ storeBinary "request" x
+ store' (PairingResponse x) = storeRec $ storeBinary "response" x
+ store' (PairingRequestNonce x) = storeRec $ storeBinary "reqnonce" x
+ store' (PairingAccept x) = store' x
+ store' (PairingDecline) = storeRec $ storeText "decline" ""
+
+ load' = do
+ res <- loadRec $ do
+ (req :: Maybe Bytes) <- loadMbBinary "request"
+ rsp <- loadMbBinary "response"
+ rnonce <- loadMbBinary "reqnonce"
+ (decline :: Maybe T.Text) <- loadMbText "decline"
+ return $ catMaybes
+ [ PairingRequest <$> (refDigestFromByteString =<< req)
+ , PairingResponse <$> rsp
+ , PairingRequestNonce <$> rnonce
+ , const PairingDecline <$> decline
+ ]
+ case res of
+ x:_ -> return x
+ [] -> PairingAccept <$> load'
+
+
+instance PairingResult a => Service (PairingService a) where
+ serviceID _ = pairingServiceID @a Proxy
+
+ type ServiceState (PairingService a) = PairingState a
+ emptyServiceState _ = NoPairing
+
+ serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
+ (NoPairing, PairingRequest confirm) -> do
+ pairingHookRequest
+ nonce <- liftIO $ getRandomBytes 32
+ svcSet $ PeerRequest nonce confirm
+ replyPacket $ PairingResponse nonce
+ (NoPairing, _) -> return ()
+
+ (OurRequest nonce, PairingResponse pnonce) -> do
+ peer <- asks $ svcPeer
+ self <- maybe (throwError "failed to validate own identity") return .
+ validateIdentity . lsIdentity . fromStored =<< svcGetLocal
+ pairingHookResponse $ confirmationNumber $ nonceDigest self peer nonce pnonce
+ svcSet $ OurRequestConfirm Nothing
+ replyPacket $ PairingRequestNonce nonce
+ (OurRequest _, _) -> do
+ svcSet $ PairingFailed
+ replyPacket PairingDecline
+
+ (OurRequestConfirm _, PairingAccept x) -> do
+ (svcSet . OurRequestConfirm =<< pairingHookConfirm x) `catchError` \_ -> do
+ svcSet $ PairingFailed
+ replyPacket PairingDecline
+
+ (OurRequestConfirm _, _) -> do
+ svcSet $ PairingFailed
+ replyPacket PairingDecline
+
+ (OurRequestReady, PairingAccept x) -> do
+ pairingHookAccept x `catchError` \_ -> do
+ svcSet $ PairingFailed
+ replyPacket PairingDecline
+ (OurRequestReady, _) -> do
+ svcSet $ PairingFailed
+ replyPacket PairingDecline
+
+ (PeerRequest nonce dgst, PairingRequestNonce pnonce) -> do
+ peer <- asks $ svcPeer
+ 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
+ svcSet PeerRequestConfirm
+ else do pairingHookRequestNonceFailed
+ svcSet PairingFailed
+ replyPacket PairingDecline
+ (PeerRequest _ _, _) -> do
+ svcSet $ PairingFailed
+ replyPacket PairingDecline
+ (PeerRequestConfirm, _) -> do
+ svcSet $ PairingFailed
+ replyPacket PairingDecline
+
+ (PairingDone, _) -> return ()
+ (PairingFailed, _) -> return ()
+
+
+nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
+nonceDigest id1 id2 nonce1 nonce2 = hashToRefDigest $ serializeObject $ Rec
+ [ (BC.pack "id", RecRef $ storedRef $ idData id1)
+ , (BC.pack "id", RecRef $ storedRef $ idData id2)
+ , (BC.pack "nonce", RecBinary $ convert nonce1)
+ , (BC.pack "nonce", RecBinary $ convert nonce2)
+ ]
+
+confirmationNumber :: RefDigest -> String
+confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: [Word32]
+ str = show $ (a .|. (b `shift` 8) .|. (c `shift` 16) .|. (d `shift` 24)) `mod` (10 ^ len)
+ in replicate (len - length str) '0' ++ str
+ where len = 6
+
+pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> UnifiedIdentity -> Peer -> m ()
+pairingRequest _ self peer = do
+ nonce <- liftIO $ getRandomBytes 32
+ pid <- case peerIdentity peer of
+ PeerIdentityFull pid -> return pid
+ _ -> throwError "incomplete peer identity"
+ sendToPeerWith @(PairingService a) self peer $ \case
+ NoPairing -> return (Just $ PairingRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce)
+ _ -> throwError "alredy in progress"