Attach device service

1 files changed, 232 insertions, 0 deletions

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 ]
+            }