From 2169f1030cded87e6ab38b4ae8293e7f147b5e96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 9 Nov 2019 21:24:57 +0100 Subject: Attach device service --- src/Attach.hs | 232 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 232 insertions(+) create mode 100644 src/Attach.hs (limited to 'src/Attach.hs') diff --git a/src/Attach.hs b/src/Attach.hs new file mode 100644 index 0000000..bf4d61e --- /dev/null +++ b/src/Attach.hs @@ -0,0 +1,232 @@ +module Attach ( + AttachService, + attachToOwner, attachAccept, +) where + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State + +import Crypto.Hash +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 qualified Data.ByteString.Lazy as BL +import Data.Maybe +import qualified Data.Text as T +import Data.Word + +import Identity +import Network +import PubKey +import Service +import State +import Storage +import Storage.Key + +data AttachService = NoAttach + | OurRequest Bytes + | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes])) + | OurRequestReady + | PeerRequest Bytes RefDigest + | PeerRequestConfirm + | AttachDone + | AttachFailed + +data AttachStage = AttachRequest RefDigest + | AttachResponse Bytes + | AttachRequestNonce Bytes + | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] + | AttachDecline + +instance Storable AttachStage 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 <$> (digestFromByteString =<< 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 + type ServicePacket AttachService = AttachStage + emptyServiceState = NoAttach + + serviceHandler spacket = gets ((,fromStored spacket) . svcValue) >>= \case + (NoAttach, AttachRequest confirm) -> do + peer <- asks $ svcPeer + svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated" + nonce <- liftIO $ getRandomBytes 32 + svcSet $ PeerRequest nonce confirm + return $ Just $ AttachResponse nonce + (NoAttach, _) -> return Nothing + + (OurRequest nonce, AttachResponse pnonce) -> do + peer <- asks $ svcPeer + self <- maybe (throwError "failed to verify own identity") return =<< + gets (verifyIdentity . lsIdentity . fromStored . svcLocal) + svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce) + svcSet $ OurRequestConfirm Nothing + return $ Just $ AttachRequestNonce nonce + (OurRequest _, _) -> do + svcSet $ AttachFailed + return $ Just $ AttachDecline + + (OurRequestConfirm _, AttachIdentity sdata keys) -> do + verifyAttachedIdentity sdata >>= \case + Just owner -> do + svcPrint $ "Attachment confirmed by peer" + svcSet $ OurRequestConfirm $ Just (owner, keys) + return Nothing + Nothing -> do + svcPrint $ "Failed to verify new identity" + svcSet $ AttachFailed + return $ Just AttachDecline + (OurRequestConfirm _, _) -> do + svcSet $ AttachFailed + return $ Just $ AttachDecline + + (OurRequestReady, AttachIdentity sdata keys) -> do + verifyAttachedIdentity sdata >>= \case + Just identity -> do + svcPrint $ "Accepted updated identity" + st <- gets $ storedStorage . svcLocal + finalizeAttach st identity keys + return Nothing + Nothing -> do + svcPrint $ "Failed to verify new identity" + svcSet $ AttachFailed + return $ Just AttachDecline + (OurRequestReady, _) -> do + svcSet $ AttachFailed + return $ Just $ AttachDecline + + (PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do + peer <- asks $ svcPeer + self <- maybe (throwError "failed to verify own identity") return =<< + gets (verifyIdentity . lsIdentity . fromStored . svcLocal) + 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 + return Nothing + else do svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer) + svcSet AttachFailed + return $ Just $ AttachDecline + (PeerRequest _ _, _) -> do + svcSet $ AttachFailed + return $ Just $ AttachDecline + (PeerRequestConfirm, _) -> do + svcSet $ AttachFailed + return $ Just $ AttachDecline + + (AttachDone, _) -> return Nothing + (AttachFailed, _) -> return Nothing + +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 (T.pack "attach") $ \case + NoAttach -> return (Just $ AttachRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce) + _ -> throwError "alredy in progress" + +attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m () +attachAccept printMsg self peer = do + let st = storedStorage $ idData self + sendToPeerWith self peer (T.pack "attach") $ \case + NoAttach -> 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 + liftIO $ printMsg $ "Accepted updated identity" + finalizeAttach st identity keys + return (Nothing, AttachDone) + OurRequestReady -> throwError $ "alredy accepted, waiting for peer" + PeerRequest {} -> throwError $ "waiting for peer" + PeerRequestConfirm -> do + liftIO $ printMsg $ "Accepted new attached device, seding updated identity" + owner <- liftIO $ mergeSharedIdentity st + PeerIdentityFull pid <- return $ peerIdentity peer + Just secret <- liftIO $ loadKey $ idKeyIdentity owner + liftIO $ 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 = hashFinalize $ hashUpdates hashInit $ + BL.toChunks $ 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 + + +verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity) +verifyAttachedIdentity sdata = do + curid <- gets $ lsIdentity . fromStored . svcLocal + secret <- maybe (throwError "failed to load own secret key") return =<< + liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid) + sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata) + return $ do + guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) == + iddKeyIdentity (fromStored $ signedData $ fromStored curid) + identity <- verifyIdentity sdata' + guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid] + return identity + + +finalizeAttach :: MonadIO m => Storage -> UnifiedIdentity -> [ScrubbedBytes] -> m () +finalizeAttach st identity skeys = do + liftIO $ updateLocalState_ st $ \slocal -> do + let owner = finalOwner identity + pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ] + mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- skeys, pub <- pkeys ] + + mshared <- mergeSharedStates (lsShared $ fromStored slocal) + shared <- wrappedStore st $ (fromStored mshared) + { ssPrev = lsShared $ fromStored slocal + , ssIdentity = [idData owner] + } + wrappedStore st (fromStored slocal) + { lsIdentity = idData identity + , lsShared = [ shared ] + } -- cgit v1.2.3