diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Attach.hs | 218 | ||||
| -rw-r--r-- | src/Pairing.hs | 163 |
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" |