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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
module Contact (
Contact(..),
contactView,
Contacts,
toContactList,
ContactService,
contactRequest,
contactAccept,
contactReject,
) where
import Control.Arrow
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import Identity
import Network
import Pairing
import PubKey
import Service
import State
import Storage
import Storage.Merge
data Contact = Contact
{ contactIdentity :: ComposedIdentity
, contactName :: Maybe Text
}
data ContactData = ContactData
{ cdPrev :: [Stored ContactData]
, cdIdentity :: [Stored (Signed IdentityData)]
, cdName :: Maybe Text
}
data Contacts = Contacts [Stored ContactData] [Contact]
toContactList :: Contacts -> [Contact]
toContactList (Contacts _ list) = list
instance Storable ContactData where
store' x = storeRec $ do
mapM_ (storeRef "PREV") $ cdPrev x
mapM_ (storeRef "identity") $ cdIdentity x
storeMbText "name" $ cdName x
load' = loadRec $ ContactData
<$> loadRefs "PREV"
<*> loadRefs "identity"
<*> loadMbText "name"
instance Mergeable Contacts where
type Component Contacts = ContactData
mergeSorted cdata = Contacts cdata $ contactView cdata
toComponents (Contacts cdata _) = cdata
instance SharedType Contacts where
sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e"
contactView :: [Stored ContactData] -> [Contact]
contactView = helper []
where helper used = filterAncestors >>> \case
x:xs | Just cid <- validateIdentityF (cdIdentity (fromStored x))
, not $ any (sameIdentity cid) used
-> Contact { contactIdentity = cid
, contactName = lookupProperty cid cdName (x:xs)
} : helper (cid:used) (cdPrev (fromStored x) ++ xs)
| otherwise -> helper used (cdPrev (fromStored x) ++ xs)
[] -> []
lookupProperty :: forall a. ComposedIdentity -> (ContactData -> Maybe a) -> [Stored ContactData] -> Maybe a
lookupProperty idt sel = join . fmap (sel . fromStored) . listToMaybe . filterAncestors . helper
where helper (x:xs) | Just cid <- validateIdentityF (cdIdentity (fromStored x))
, cid `sameIdentity` idt
, Just _ <- sel $ fromStored x
= x : helper xs
| otherwise = helper $ cdPrev (fromStored x) ++ xs
helper [] = []
type ContactService = PairingService ContactAccepted
data ContactAccepted = ContactAccepted
instance Storable ContactAccepted where
store' ContactAccepted = storeRec $ do
storeText "accept" ""
load' = loadRec $ do
(_ :: T.Text) <- loadText "accept"
return ContactAccepted
instance PairingResult ContactAccepted where
pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084"
pairingVerifyResult = return . Just
pairingFinalizeRequest ContactAccepted = do
pid <- asks svcPeerIdentity
finalizeContact pid
pairingFinalizeResponse = do
pid <- asks svcPeerIdentity
finalizeContact pid
return ContactAccepted
defaultPairingAttributes _ = PairingAttributes
{ pairingHookRequest = do
peer <- asks $ svcPeerIdentity
svcPrint $ "Contact pairing from " ++ T.unpack (displayIdentity peer) ++ " initiated"
, pairingHookResponse = \confirm -> do
peer <- asks $ svcPeerIdentity
svcPrint $ "Confirm contact " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
, pairingHookRequestNonce = \confirm -> do
peer <- asks $ svcPeerIdentity
svcPrint $ "Contact request from " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
, pairingHookRequestNonceFailed = do
peer <- asks $ svcPeerIdentity
svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)
, pairingHookConfirmedResponse = do
svcPrint $ "Contact accepted, waiting for peer confirmation"
, pairingHookConfirmedRequest = do
svcPrint $ "Contact confirmed by peer"
, pairingHookAcceptedResponse = do
svcPrint $ "Contact accepted"
, pairingHookAcceptedRequest = do
svcPrint $ "Contact accepted"
, pairingHookVerifyFailed = return ()
, pairingHookRejected = do
svcPrint $ "Contact rejected by peer"
, pairingHookFailed = do
svcPrint $ "Contact failed"
}
contactRequest :: (MonadIO m, MonadError String m) => Peer -> m ()
contactRequest = pairingRequest @ContactAccepted Proxy
contactAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
contactAccept = pairingAccept @ContactAccepted Proxy
contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
contactReject = pairingReject @ContactAccepted Proxy
finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()
finalizeContact identity = updateSharedState_ $ \(Contacts prev _) -> do
let st = storedStorage $ idData identity
contact <- wrappedStore st ContactData
{ cdPrev = prev
, cdIdentity = idDataF $ finalOwner identity
, cdName = Nothing
}
return $ Contacts [contact] (contactView [contact])
|