diff options
Diffstat (limited to 'src/Attach.hs')
| -rw-r--r-- | src/Attach.hs | 218 |
1 files changed, 64 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 ] - } + } |