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"
defaultPairingAttributes _ = PairingAttributes
{ 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 ()) -> 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
sendToPeerWith 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 ]
}
|