summaryrefslogtreecommitdiff
path: root/src/Attach.hs
blob: 055c7fe1f8e6b238771a3ce65725dda6749d97b6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
module Attach (
    AttachService,
    attachToOwner, attachAccept,
) where

import Control.Monad.Except
import Control.Monad.Reader

import Data.ByteArray (ScrubbedBytes)
import Data.Maybe
import Data.Proxy
import qualified Data.Text as T

import Identity
import Network
import Pairing
import PubKey
import Service
import State
import Storage
import Storage.Key

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 $ svcPeerIdentity
        svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"

    pairingHookResponse confirm = do
        peer <- asks $ svcPeerIdentity
        svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm

    pairingHookRequestNonce confirm = do
        peer <- asks $ svcPeerIdentity
        svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm

    pairingHookRequestNonceFailed = do
        peer <- asks $ svcPeerIdentity
        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 _ = 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
        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 (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, PairingDone)
        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 h
            PeerIdentityFull pid <- 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 $ 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
    curid <- lsIdentity . fromStored <$> svcGetLocal
    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 <- validateIdentity sdata'
        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
        st = storedStorage slocal
    pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
    mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- skeys, pub <- pkeys ]

    shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal)
    wrappedStore st (fromStored slocal)
        { lsIdentity = idData identity
        , lsShared = [ shared ]
        }