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
|
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]
instance Storable AttachIdentity where
store' (AttachIdentity x keys) = storeRec $ do
storeRef "identity" x
mapM_ (storeBinary "skey") keys
load' = loadRec $ AttachIdentity
<$> loadRef "identity"
<*> loadBinaries "skey"
instance PairingResult AttachIdentity where
pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
type PairingVerifiedResult AttachIdentity = (UnifiedIdentity, [ScrubbedBytes])
pairingVerifyResult (AttachIdentity sdata keys) = 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, keys)
pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> do
let owner = finalOwner identity
st = storedStorage slocal
pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ]
shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal)
wrappedStore st (fromStored slocal)
{ lsIdentity = idData identity
, lsShared = [ shared ]
}
pairingFinalizeResponse = do
st <- storedStorage <$> svcGetLocal
owner <- mergeSharedIdentity
pid <- asks svcPeerIdentity
secret <- maybe (throwError "failed to load secret key") return =<< liftIO (loadKey $ idKeyIdentity owner)
identity <- liftIO $ wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid)
{ iddPrev = [idData pid], iddOwner = Just (idData owner) }
skeys <- liftIO $ map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ]
return $ AttachIdentity identity skeys
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)
, pairingHookConfirmedResponse = do
svcPrint $ "Confirmed peer, waiting for updated identity"
, pairingHookConfirmedRequest = do
svcPrint $ "Attachment confirmed by peer"
, pairingHookAcceptedResponse = do
svcPrint $ "Accepted updated identity"
, pairingHookAcceptedRequest = do
svcPrint $ "Accepted new attached device, seding updated identity"
, pairingHookVerifyFailed = do
svcPrint $ "Failed to verify new identity"
}
attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m ()
attachToOwner = pairingRequest @AttachIdentity Proxy
attachAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
attachAccept = pairingAccept @AttachIdentity Proxy
|