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
|
module Contact (
Contact(..),
contactView,
ContactService,
contactRequest,
contactAccept,
) where
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
}
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 SharedType ContactData where
sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e"
contactView :: [Stored ContactData] -> [Contact]
contactView = helper [] . filterAncestors
where helper used (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) xs
| otherwise = helper used xs
helper _ [] = []
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"
pairingHookRequest = do
peer <- asks $ svcPeer
svcPrint $ "Contact pairing from " ++ T.unpack (displayIdentity peer) ++ " initiated"
pairingHookResponse confirm = do
peer <- asks $ svcPeer
svcPrint $ "Confirm contact " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
pairingHookRequestNonce confirm = do
peer <- asks $ svcPeer
svcPrint $ "Contact request from " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm
pairingHookRequestNonceFailed = do
peer <- asks $ svcPeer
svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)
pairingHookConfirm ContactAccepted = do
svcPrint $ "Contact confirmed by peer"
return $ Just ContactAccepted
pairingHookAccept ContactAccepted = return ()
contactRequest :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m ()
contactRequest _ = pairingRequest @ContactAccepted Proxy
contactAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m ()
contactAccept printMsg h peer = do
let self = headLocalIdentity h
sendToPeerWith self peer $ \case
NoPairing -> throwError $ "none in progress"
OurRequest {} -> throwError $ "waiting for peer"
OurRequestConfirm Nothing -> do
liftIO $ printMsg $ "Contact accepted, waiting for peer confirmation"
return (Nothing, OurRequestReady)
OurRequestConfirm (Just ContactAccepted) -> do
PeerIdentityFull pid <- return $ peerIdentity peer
liftIO $ do
printMsg $ "Contact accepted"
updateLocalState_ h $ finalizeContact pid
return (Nothing, PairingDone)
OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
PeerRequest {} -> throwError $ "waiting for peer"
PeerRequestConfirm -> do
PeerIdentityFull pid <- return $ peerIdentity peer
liftIO $ do
printMsg $ "Contact accepted"
updateLocalState_ h $ finalizeContact pid
return (Just $ PairingAccept ContactAccepted, PairingDone)
PairingDone -> throwError $ "alredy done"
PairingFailed -> throwError $ "alredy failed"
finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
finalizeContact identity slocal = liftIO $ do
let st = storedStorage slocal
contact <- wrappedStore st ContactData
{ cdPrev = lookupSharedValue $ lsShared $ fromStored slocal
, cdIdentity = idDataF $ finalOwner identity
, cdName = Nothing
}
shared <- makeSharedStateUpdate st [contact] (lsShared $ fromStored slocal)
wrappedStore st (fromStored slocal) { lsShared = [shared] }
|