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 --- erebos.cabal | 3 +- src/Attach.hs | 232 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 20 ++++- src/Message/Service.hs | 2 +- src/Network.hs | 45 ++++++---- src/PubKey.hs | 12 ++- src/Service.hs | 15 +++- src/State.hs | 13 +++ src/Storage.hs | 14 ++- 9 files changed, 331 insertions(+), 25 deletions(-) create mode 100644 src/Attach.hs diff --git a/erebos.cabal b/erebos.cabal index 8218d91..98310b4 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -18,7 +18,8 @@ cabal-version: >=1.10 executable erebos ghc-options: -Wall main-is: Main.hs - other-modules: Identity, + other-modules: Attach + Identity, Channel, Message, Message.Service 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 ] + } diff --git a/src/Main.hs b/src/Main.hs index 9e87af5..0e1daf7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -22,6 +22,7 @@ import Data.Time.LocalTime import System.Console.Haskeline import System.Environment +import Attach import Identity import Message import Message.Service @@ -70,7 +71,8 @@ interactiveLoop st bhost = runInputT defaultSettings $ do let extPrintLn str = extPrint $ str ++ "\n"; chanPeer <- liftIO $ startServer extPrintLn bhost self - [ (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService)) + [ (T.pack "attach", SomeService (emptyServiceState :: AttachService)) + , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService)) ] peers <- liftIO $ newMVar [] @@ -110,6 +112,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput { ciSelf = self , ciLine = line + , ciPrint = extPrintLn , ciPeers = liftIO $ readMVar peers } case res of @@ -125,6 +128,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do data CommandInput = CommandInput { ciSelf :: UnifiedIdentity , ciLine :: String + , ciPrint :: String -> IO () , ciPeers :: CommandM [Peer] } @@ -149,6 +153,8 @@ commands = , ("peers", cmdPeers) , ("send", cmdSend) , ("update-identity", cmdUpdateIdentity) + , ("attach", cmdAttach) + , ("attach-accept", cmdAttachAccept) ] cmdUnknown :: String -> Command @@ -213,3 +219,15 @@ cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do st <- asks $ storedStorage . idData . ciSelf liftIO $ updateIdentity st + +cmdAttach :: Command +cmdAttach = join $ attachToOwner + <$> asks ciPrint + <*> asks ciSelf + <*> (maybe (throwError "no peer selected") return =<< gets csPeer) + +cmdAttachAccept :: Command +cmdAttachAccept = join $ attachAccept + <$> asks ciPrint + <*> asks ciSelf + <*> (maybe (throwError "no peer selected") return =<< gets csPeer) diff --git a/src/Message/Service.hs b/src/Message/Service.hs index a798fb5..37aa3ab 100644 --- a/src/Message/Service.hs +++ b/src/Message/Service.hs @@ -1,5 +1,5 @@ module Message.Service ( - DirectMessageService, + DirectMessageService(..), formatMessage, ) where diff --git a/src/Network.hs b/src/Network.hs index bff793a..7d70d1d 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -6,7 +6,7 @@ module Network ( WaitingRef, wrDigest, Service(..), startServer, - sendToPeer, + sendToPeer, sendToPeerWith, ) where import Control.Concurrent @@ -43,7 +43,7 @@ data Peer = Peer , peerSocket :: Socket , peerStorage :: Storage , peerInStorage :: PartialStorage - , peerServiceState :: M.Map T.Text SomeService + , peerServiceState :: MVar (M.Map T.Text SomeService) , peerServiceQueue :: [(T.Text, WaitingRef)] , peerWaitingRefs :: [WaitingRef] } @@ -184,6 +184,7 @@ startServer logd bhost identity services = do | otherwise -> do pst <- deriveEphemeralStorage $ storedStorage sidentity ist <- derivePartialStorage pst + svcs <- newMVar M.empty let peer = Peer { peerAddress = DatagramAddress paddr , peerIdentity = PeerIdentityUnknown @@ -192,7 +193,7 @@ startServer logd bhost identity services = do , peerSocket = sock , peerStorage = pst , peerInStorage = ist - , peerServiceState = M.empty + , peerServiceState = svcs , peerServiceQueue = [] , peerWaitingRefs = [] } @@ -226,19 +227,20 @@ startServer logd bhost identity services = do (peer, svc, ref) | PeerIdentityFull peerId <- peerIdentity peer , PeerIdentityFull peerOwnerId <- peerOwner peer - , DatagramAddress paddr <- peerAddress peer - -> case maybe (lookup svc services) Just $ M.lookup svc (peerServiceState peer) of - Nothing -> logd $ "unhandled service '" ++ T.unpack svc ++ "'" - Just (SomeService s) -> do - let inp = ServiceInput - { svcPeer = peerId, svcPeerOwner = peerOwnerId - , svcPrintOp = logd - } - (rsp, s') <- handleServicePacket (storedStorage sidentity) inp s (wrappedLoad ref) - modifyMVar_ peers $ return . M.adjust (\p -> p { peerServiceState = M.insert svc (SomeService s') $ peerServiceState p }) paddr - runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case - Left err -> logd $ "failed to send response to peer: " ++ show err - Right () -> return () + -> modifyMVar_ (peerServiceState peer) $ \svcs -> + case maybe (lookup svc services) Just $ M.lookup svc svcs of + Nothing -> do logd $ "unhandled service '" ++ T.unpack svc ++ "'" + return svcs + Just (SomeService s) -> do + let inp = ServiceInput + { svcPeer = peerId, svcPeerOwner = peerOwnerId + , svcPrintOp = logd + } + (rsp, s') <- handleServicePacket (storedStorage sidentity) inp s (wrappedLoad ref) + runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case + Left err -> logd $ "failed to send response to peer: " ++ show err + Right () -> return () + return $ M.insert svc (SomeService s') svcs | DatagramAddress paddr <- peerAddress peer -> do logd $ "service packet from peer with incomplete identity " ++ show paddr @@ -491,3 +493,14 @@ sendToPeer _ peer@Peer { peerChannel = ChannelEstablished ch } svc obj = do void $ liftIO $ sendTo (peerSocket peer) ctext paddr sendToPeer _ _ _ _ = throwError $ "no channel to peer" + +sendToPeerWith :: (Service s, MonadIO m, MonadError String m) => UnifiedIdentity -> Peer -> T.Text -> (s -> ExceptT String IO (Maybe (ServicePacket s), s)) -> m () +sendToPeerWith identity peer svc fobj = do + res <- liftIO $ modifyMVar (peerServiceState peer) $ \svcs -> do + runExceptT (fobj $ fromMaybe emptyServiceState $ fromService =<< M.lookup svc svcs) >>= \case + Right (obj, s') -> return $ (M.insert svc (SomeService s') svcs, Right obj) + Left err -> return $ (svcs, Left err) + case res of + Right (Just obj) -> sendToPeer identity peer svc obj + Right Nothing -> return () + Left err -> throwError err diff --git a/src/PubKey.hs b/src/PubKey.hs index d7134c8..8f39bf1 100644 --- a/src/PubKey.hs +++ b/src/PubKey.hs @@ -48,7 +48,11 @@ signedSignature = signedSignature_ instance KeyPair SecretKey PublicKey where keyGetPublic (SecretKey _ pub) = pub keyGetData (SecretKey sec _) = convert sec - keyFromData kdata spub = SecretKey <$> maybeCryptoError (ED.secretKey kdata) <*> pure spub + keyFromData kdata spub = do + skey <- maybeCryptoError $ ED.secretKey kdata + let PublicKey pkey = fromStored spub + guard $ ED.toPublic skey == pkey + return $ SecretKey skey spub generateKeys st = do secret <- ED.generateSecretKey public <- wrappedStore st $ PublicKey $ ED.toPublic secret @@ -115,7 +119,11 @@ data SecretKexKey = SecretKexKey CX.SecretKey (Stored PublicKexKey) instance KeyPair SecretKexKey PublicKexKey where keyGetPublic (SecretKexKey _ pub) = pub keyGetData (SecretKexKey sec _) = convert sec - keyFromData kdata spub = SecretKexKey <$> maybeCryptoError (CX.secretKey kdata) <*> pure spub + keyFromData kdata spub = do + skey <- maybeCryptoError $ CX.secretKey kdata + let PublicKexKey pkey = fromStored spub + guard $ CX.toPublic skey == pkey + return $ SecretKexKey skey spub generateKeys st = do secret <- CX.generateSecretKey public <- wrappedStore st $ PublicKexKey $ CX.toPublic secret diff --git a/src/Service.hs b/src/Service.hs index 667196d..f08a7a2 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -1,11 +1,12 @@ module Service ( Service(..), - SomeService(..), + SomeService(..), fromService, ServiceHandler, ServiceInput(..), ServiceState(..), handleServicePacket, + svcSet, svcPrint, ) where @@ -13,17 +14,22 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State +import Data.Typeable + import Identity import State import Storage -class Storable (ServicePacket s) => Service s where +class (Typeable s, Storable (ServicePacket s)) => Service s where type ServicePacket s :: * emptyServiceState :: s serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s)) data SomeService = forall s. Service s => SomeService s +fromService :: Service s => SomeService -> Maybe s +fromService (SomeService s) = cast s + data ServiceInput = ServiceInput { svcPeer :: UnifiedIdentity , svcPeerOwner :: UnifiedIdentity @@ -36,7 +42,7 @@ data ServiceState s = ServiceState } newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceState s) (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadIO) + deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadError String, MonadIO) handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s) handleServicePacket st input svc packet = do @@ -54,5 +60,8 @@ handleServicePacket st input svc packet = do Left _ -> handleServicePacket st input svc packet Right _ -> return (rsp, svcValue sstate') +svcSet :: s -> ServiceHandler s () +svcSet x = modify $ \st -> st { svcValue = x } + svcPrint :: String -> ServiceHandler s () svcPrint str = liftIO . ($str) =<< asks svcPrintOp diff --git a/src/State.hs b/src/State.hs index 91fff2b..515391d 100644 --- a/src/State.hs +++ b/src/State.hs @@ -4,6 +4,10 @@ module State ( loadLocalState, updateLocalState, updateLocalState_, + updateSharedState, updateSharedState_, + mergeSharedStates, + + mergeSharedIdentity, updateIdentity, ) where @@ -119,6 +123,15 @@ mergeSharedStates ss@(s:_) = wrappedStore (storedStorage s) $ SharedState } mergeSharedStates [] = error "mergeSharedStates: empty list" + +mergeSharedIdentity :: Storage -> IO UnifiedIdentity +mergeSharedIdentity st = updateSharedState st $ \sshared -> do + let shared = fromStored sshared + Just cidentity = verifyIdentityF $ ssIdentity shared + identity <- mergeIdentity cidentity + sshared' <- wrappedStore st $ shared { ssIdentity = [idData identity] } + return (sshared', identity) + updateIdentity :: Storage -> IO () updateIdentity st = updateSharedState_ st $ \sshared -> do let shared = fromStored sshared diff --git a/src/Storage.hs b/src/Storage.hs index d78d99a..d29056f 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -29,12 +29,14 @@ module Storage ( loadBlob, loadRec, loadZero, loadInt, loadNum, loadText, loadBinary, loadDate, loadJson, loadRef, - loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbJson, loadMbRef, loadRefs, + loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbJson, loadMbRef, + loadBinaries, loadRefs, loadZRef, Stored, fromStored, storedRef, storedStorage, wrappedStore, wrappedLoad, + copyStored, StoreInfo(..), makeStoreInfo, @@ -631,6 +633,12 @@ loadMbBinary name = asks (lookup (BC.pack name) . snd) >>= \case Just (RecBinary x) -> return $ Just $ BA.convert x Just _ -> throwError $ "Expecting type binary of record item '"++name++"'" +loadBinaries :: BA.ByteArray a => String -> LoadRec [a] +loadBinaries name = do + items <- map snd . filter ((BC.pack name ==) . fst) <$> asks snd + forM items $ \case RecBinary x -> return $ BA.convert x + _ -> throwError $ "Expecting type binary of record item '"++name++"'" + loadDate :: StorableDate a => String -> LoadRec a loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name @@ -719,6 +727,10 @@ wrappedStore st x = do ref <- store st x wrappedLoad :: Storable a => Ref -> Stored a wrappedLoad ref = Stored ref (load ref) +copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => + Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a)) +copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref' + data StoreInfo = StoreInfo { infoDate :: ZonedTime -- cgit v1.2.3